Orner mit Unterordnern öffnen und Daten auslesen

Hallo liebe Excelfreunde,
ich stehe vor einem kleinen Problem:
Ich bin auf der Suche nach einem Code, der mir einen Ordner und dessen Unterordner nach Exceldateien durchsuchen soll. Im Forum habe ich schon viel gelesen, und auch einen Code gefunden, der in die Richtige richtung geht, aber nicht genau das ist was ich brauche.
Meine Arbeitsschritte teilen sich in insgesamt 6 Schritte auf.
Aus jeder gefundenen Exceldatei sollen Daten exportiert werden.
Ich habe mir folgendes gedacht:
Quelldatei: Mehrere Exceldateien in Unterordern die auf dem laufwerk abliegen.
Zieldatei: Konsolidierte Datei (aktiviert), Daten aus allen Exeldateien sollen in Tabellenblatt Tabelle1 importiert werden.
1. Öffne Ordner unter Pfad: \\muc-file03\Data\Marketing\MARKETING_PUBLIC\Online_Teaserplanung\
2. Schleife 1:
Öffne jeden Unterordner des geöffneten Ordners (ca. 20 Stück) von oben nach unten
' Mit FileSearch samt SearchSubFolders ?
3. Schleife2:
Öffne nacheinander jede Exceldatei (Quelldatei) in Unterordner (auch mehrere Exceldateien möglich)
4. Schleife 3:
Prüfe in Quelldatei Spalte A, Zelle (A1 A200) bis Zahl aus aktiven Sheet Tabelle 1 (Zieldatei) Zelle C1 gefunden
Wenn Zahl aus C1 gefunden dann
5. Schleife:
Führe Kopiervorgang Zeile für Zeile durch, ab der gefunden Zahl in Schritt 4.
Es sollen genau so viele Zeilen nacheinander kopiert werden (Anzahl) wie in Zelle I1 in Tabelle1 (Zieldatei) steht.
Z.B. Zahl aus I1 tabelle1 = 4; es werden 4 Zeilen (einschlißlich Zeile mit gefundener Zahl) in die Zieldatei Tabelle1 nacheinander exportiert.
Wichtig ist dass die Zeile (Quelldatei) in eine leere Zeile (Zieldatei) exportiert wird (daher vor Export Prüfung nötig)
Jeder Zeile die exportiert wird muss in die nächst möglich freie Zeile in Zieldatei exportiert werden. (siehe Schleife 6)
6.Schleife
Prüfe Zeile für Zeile Tabelle C8 C200 ob Zelle ist leer.
Wenn Zell ist leer dann:
Kopiere Inhalt Zelle A in Tabelle 1 Zelle C
Kopiere Inhalt Zelle B in Tabelle 1 Zelle E
Kopiere Inhalt Zelle C in Tabelle 1 Zelle G
Kopiere Inhalt Zelle F in Tabelle 1 Zelle H
Zwei Zellen erhalten immer feste Werte:
Tabelle1 Zelle A = OC
Tabelle1 Zelle L = ja
Ich habe etwas Startschwierigkeiten und wäre vor allem für einen tipp bezüglich Schritt 1 und 2 sehr dankbar.
Wenn jemand so ein ähnlichen Fall schon mal im Forum gefunden hat und sich noch an das Wording errinnert, würde ich mich sehr über einen kurzen Hinweis freuen.
Viele Grüße aus München,
Jeron

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Jeron,

ungetestet!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importData()
  Dim objFiles() As Object
  Dim objWB As Workbook, objSh As Worksheet
  Dim lngRow As Long, lngCnt As Long, lngIndex As Long, lngRet As Long
  Dim strTab As String, strPath As String
  Dim vntRet As Variant

  On Error GoTo ErrExit
  GMS

  strPath = "E:\Forum" 'Startverzeichnis - Anpassen!
  strTab = "Tabelle1" 'Tabellenname aus welcher ausgelesen wird - Anpassen!

  lngRet = FileSearchINFO(objFiles, strPath, ".xls*", True)

  If lngRet > 0 Then
    Set objSh = ThisWorkbook.Sheets("Tabelle1") 'Name der Zieltabelle - Anpassen!
    lngCnt = objSh.Range("I1")
    lngRow = Application.Max(8, objSh.Cells(objSh.Rows.Count, 3).End(xlUp).Row + 1)
    For lngIndex = 0 To lngRet - 1
      If Not objFiles(lngIndex) = ThisWorkbook.FullName Then
        Set objWB = Workbooks.Open(objFiles(lngIndex))
        If SheetExist(strTab, objWB) Then
          With objWB.Sheets(strTab)
            vntRet = Application.Match(objSh.Range("C1"), .Range("A1:A200"), 0)
            If IsNumeric(vntRet) Then
              .Cells(vntRet, 1).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 3)
              .Cells(vntRet, 2).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 5)
              .Cells(vntRet, 3).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 7)
              .Cells(vntRet, 6).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 8)
              objSh.Cells(lngRow, 1).Resize(lngCnt, 1) = "OC"
              objSh.Cells(lngRow, 12).Resize(lngCnt, 1) = "ja"
              lngRow = lngRow + lngCnt
            End If
          End With
        End If
        objWB.Close False
      End If
    Next
  End If

  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (importData) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / importData"
  End With

  GMS True

  Set objWB = Nothing
  Set objSh = Nothing
End Sub

Private Sub GMS(Optional ByVal Modus As Boolean = False)

  Static lngCalc As Long

  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)

  End With

End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

  '# PARAMETERINFO:
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
  '# Beispiele: "*.txt" - Findet alle Textdateien
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant

  Set fobjFSO = CreateObject("Scripting.FileSystemObject")

  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

  On Error GoTo ErrExit

  If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
  Else
    Redim varFiles(0)
    varFiles(0) = FileName
  End If
  For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
      For intC = 0 To UBound(varFiles)
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            Redim Preserve Files(UBound(Files) + 1)
          Else
            Redim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next

  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If

  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
  ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

Gruß Sepp

Sub importData() Dim objFiles() As Object Dim objWB As Workbook, objSh As Worksheet Dim lngRow As Long, lngCnt As Long, lngIndex As Long, lngRet As Long Dim strTab As String, strPath As String Dim vntRet As Variant On Error GoTo ErrExit GMS strPath = "C:\Dokumente und Einstellungen\jbitto\Desktop\Testing" 'Startverzeichnis - _ Anpassen! strTab = "Mediaplanung2010" 'Tabellenname aus welcher ausgelesen wird - Anpassen! lngRet = FileSearchINFO(objFiles, strPath, "*.xls*", True) If lngRet > 0 Then Set objSh = ThisWorkbook.Sheets("Tabelle1") 'Name der Zieltabelle - Anpassen! lngCnt = objSh.Range("I1") lngRow = Application.Max(8, objSh.Cells(objSh.Rows.Count, 3).End(xlUp).Row + 1) For lngIndex = 0 To lngRet - 1 If Not objFiles(lngIndex) = ThisWorkbook.FullName Then Set objWB = Workbooks.Open(objFiles(lngIndex)) If SheetExist(strTab, objWB) Then With objWB.Sheets(strTab) vntRet = Application.Match(objSh.Range("C1"), .Range("A1:A200"), 0) If IsNumeric(vntRet) Then 'wenn die Zahl gefunden wurde, dann soll Kopiervorgang erfolgen, aber ' vor jedem Kopiervorgang pro Zeile soll überprüft werden, ob in ' gleichen Zeile in Spalte B (Quelldatei) ein Wert steht, ist kein Wert vorhanden _ _ soll Zeile ' nicht kopiert werden .Cells(vntRet, 1).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 3) .Cells(vntRet, 2).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 5) .Cells(vntRet, 3).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 7) .Cells(vntRet, 6).Resize(lngCnt, 1).Copy objSh.Cells(lngRow, 8) ' kann hier noch eingefügt werden, dass Wert aus objWB.Sheets(strTab) "B3" für _ _ _ jeden ' Kopiervorgang pro Zeile in Spalte 4 (Zieldatei) eingefügt wird? objSh.Cells(lngRow, 1).Resize(lngCnt, 1) = "OC" objSh.Cells(lngRow, 12).Resize(lngCnt, 1) = "ja" lngRow = lngRow + lngCnt End If End With End If objWB.Close False End If Next End If ErrExit: With Err If .Number 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _ .Description & vbLf & vbLf & "In Prozedur (importData) in Modul Modul1", _ vbExclamation, "Fehler in Modul1 / importData" End With GMS True Set objWB = Nothing Set objSh = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Orner mit Unterordnern öffnen und Daten auslesen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Orner mit Unterordnern öffnen und Daten auslesen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread