Hallo Zusammen,

ich habe folgendes Problem:

Mein Makro funktioniert nicht richtig:

Ich möchte alle "Stundenzettel" aus verschiedenen Unterordnern öffnen, bestimmte Zeilen kopieren und in meine Haupttabelle einfügen, wobei der Hauptordner per FolderPicker auswählbar ist.

Da ich Anfänger bin, habe ich das Makro aus anderen "zusammengebastelt".

Es funktioniert auch ganz gut. Nur ich verzweifele daran, dass er nicht alle Unterordner aussliest, sondern nur den ersten Unterordner.

Die Stundenzettel können sich in den auswählbaren Hauptordner oder auch in verschiedenen Unterordnern befinden.

Ich vermute, dass das für einen erfahrenen VB-Spezi ´ne Kleinigkeit ist.??

Für jede Hilfe bin ich dankbar, ich komme einfach nicht weiter.....

Option Explicit

Dim objFileSystemObject As Object
Dim objDateien As Object
Dim objWeitereDateien As Object
Dim objDatei As Object
Dim lngFirstFreeRow As Long
Dim wksAuswertsheet As Worksheet
Dim lngIndex As Long
Dim strOrdner As String


Sub Smiley1_Klicken()

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten

Dateiname = Application.ActiveWorkbook.Name

Sheets("Tabelle1").Activate
Range(Cells(2, "A"), Cells(Rows.Count, "AC")).ClearContents

   
  With Application.FileDialog(msoFileDialogFolderPicker)
       .InitialFileName = ThisWorkbook.Path & "\"
       .Title = "Ordnerauswahl - nur Stundenzettel"
       .ButtonName = "Auswahl..."
       .InitialView = msoFileDialogViewList
       If .Show = -1 Then
          strOrdner = .SelectedItems(1)
          If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
         Else
         strOrdner = ""
        End If
   End With
   If strOrdner = "" Then MsgBox ("Kein Ordner gewählt!"), vbInformation

sprungziel:

'Objektverweise zuweisen
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.GetFolder(strOrdner)
Set wksAuswertsheet = ThisWorkbook.Sheets("Tabelle1")
    
'-------------------------------------------------------------------------

For Each objDatei In objDateien.Files
If objDatei.Name Like "*Stunden*" And objDatei.Name Like "*.xls" Or objDatei.Name Like "*Std*" And objDatei.Name Like "*.xls" Then

'erste freie Zelle in der Zieldatei in Spalte A ermitteln
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'Meldung in Statusbar anzeigen
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents

'Gefundene Datei unsichtbar öffnen
GetObject (objDatei)


'Wert aus geöffneter Datei aus dem Tabellenblatt 1 in aktueller übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 3) = _
Workbooks(objDatei.Name).Sheets(1).Range("D4")
wksAuswertsheet.Cells(lngFirstFreeRow, 4) = _
Workbooks(objDatei.Name).Sheets(1).Range("E12")
wksAuswertsheet.Cells(lngFirstFreeRow, 5) = _
Workbooks(objDatei.Name).Sheets(1).Range("G47")
wksAuswertsheet.Cells(lngFirstFreeRow, 6) = _
Workbooks(objDatei.Name).Sheets(1).Range("C5")
wksAuswertsheet.Cells(lngFirstFreeRow, 7) = _
Workbooks(objDatei.Name).Sheets(1).Range("D9")
wksAuswertsheet.Cells(lngFirstFreeRow, 8) = _
Workbooks(objDatei.Name).Sheets(1).Range("E9")
wksAuswertsheet.Cells(lngFirstFreeRow, 9) = _
Workbooks(objDatei.Name).Sheets(1).Range("D10")
wksAuswertsheet.Cells(lngFirstFreeRow, 10) = _
Workbooks(objDatei.Name).Sheets(1).Range("E10")
wksAuswertsheet.Cells(lngFirstFreeRow, 11) = _
Workbooks(objDatei.Name).Sheets(1).Range("D11")
wksAuswertsheet.Cells(lngFirstFreeRow, 12) = _
Workbooks(objDatei.Name).Sheets(1).Range("E11")
wksAuswertsheet.Cells(lngFirstFreeRow, 13) = _
Workbooks(objDatei.Name).Sheets(1).Range("D4")
wksAuswertsheet.Cells(lngFirstFreeRow, 14) = _
Workbooks(objDatei.Name).Sheets(1).Range("E12")
wksAuswertsheet.Cells(lngFirstFreeRow, 15) = _
Workbooks(objDatei.Name).Sheets(1).Range("G47")
wksAuswertsheet.Cells(lngFirstFreeRow, 16) = _
Workbooks(objDatei.Name).Sheets(1).Range("K5")
wksAuswertsheet.Cells(lngFirstFreeRow, 17) = _
Workbooks(objDatei.Name).Sheets(1).Range("L9")
wksAuswertsheet.Cells(lngFirstFreeRow, 18) = _
Workbooks(objDatei.Name).Sheets(1).Range("M9")
wksAuswertsheet.Cells(lngFirstFreeRow, 19) = _
Workbooks(objDatei.Name).Sheets(1).Range("L10")
wksAuswertsheet.Cells(lngFirstFreeRow, 20) = _
Workbooks(objDatei.Name).Sheets(1).Range("M10")
wksAuswertsheet.Cells(lngFirstFreeRow, 21) = _
Workbooks(objDatei.Name).Sheets(1).Range("L11")
wksAuswertsheet.Cells(lngFirstFreeRow, 22) = _
Workbooks(objDatei.Name).Sheets(1).Range("M11")
wksAuswertsheet.Cells(lngFirstFreeRow, 23) = _
Workbooks(objDatei.Name).Sheets(1).Range("R9")
wksAuswertsheet.Cells(lngFirstFreeRow, 24) = _
Workbooks(objDatei.Name).Sheets(1).Range("S9")
wksAuswertsheet.Cells(lngFirstFreeRow, 25) = _
Workbooks(objDatei.Name).Sheets(1).Range("R10")
wksAuswertsheet.Cells(lngFirstFreeRow, 26) = _
Workbooks(objDatei.Name).Sheets(1).Range("S10")
wksAuswertsheet.Cells(lngFirstFreeRow, 27) = _
Workbooks(objDatei.Name).Sheets(1).Range("R11")
wksAuswertsheet.Cells(lngFirstFreeRow, 28) = _
Workbooks(objDatei.Name).Sheets(1).Range("S11")
wksAuswertsheet.Cells(lngFirstFreeRow, 29) = _
Workbooks(objDatei.Name).Sheets(1).Range("U33")

'HYPERLINK
wksAuswertsheet.Hyperlinks.Add Anchor:=wksAuswertsheet.Cells(lngFirstFreeRow, 1), _
Address:=strOrnder & objDatei.Name

'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close SaveChanges:=False

End If
Next

'Nächstes Verzeichnis abfragen
Dim SubFolder As Object
For Each SubFolder In objDateien.SubFolders
Set strOrdner = SubFolder

GoTo sprungziel

Next SubFolder

'-------------------------------------------------------------------------

  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
 
 'Zuweisung wieder aufheben
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing

'Text aus Statusbar löschen
Application.StatusBar = ""
 
    ThisWorkbook.Save:  MsgBox "Fertig - Stundenzettel eingelesen", vbInformation, "Stundenzettel einlesen..."
End Sub