'===================================
'Daten sammeln
'===================================
For Each objSubfolder In objSubfolders 'Unterverzeichnisse durlaufen
If objSubfolder.Name Like "####" And _
objSubfolder.SubFolders.Count > 0 Then 'Wenn Unterverzeichnisname = 4Ziffern
Set wksDest = wbkDest.Sheets.Add _
(after:=wbkDest.Sheets(wbkDest.Sheets.Count), Type:=xlWorksheet) 'neues JahresSheet
wksDest.Name = objSubfolder.Name 'Name = Jahr
lngCol = 0 'Spaltenzaehler ruecksetzen
lngMaxRow = 0 'MaxZeile zuruecksetzen
For Each objSubSubFolder In objSubfolder.SubFolders 'UnterUnterverzeichnisse durchlaufen
If objSubSubFolder.Name Like "KW##" Then 'Wenn .Name = KW und 2 Ziffern
If lngCol = 0 Then 'Spaltenweiterschaltung
lngCol = lngCol + 1 'erste Spalte=1=A
Else
lngCol = lngCol + 4 'dann 4Spalten weiter
End If
wksDest.Cells(1, lngCol).Value = objSubSubFolder.Name 'Verzeinisname in Zelle
wksDest.Cells(1, lngCol).HorizontalAlignment = xlCenter 'ausrichten
wksDest.Cells(1, lngCol).Font.Bold = True 'Schrift Fett
wksDest.Range(Cells(1, lngCol), Cells(1, lngCol + 2)).Merge 'Zeilen zusammenfügen
wksDest.Cells(2, lngCol).Value = "Baustellenadresse" 'Kopf benennen
wksDest.Cells(2, lngCol).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(2, lngCol + 1).Value = "Stunden" 'Kopf benennen
wksDest.Cells(2, lngCol + 1).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(2, lngCol + 2).Value = "Betrag" 'Kopf benennen
wksDest.Cells(2, lngCol + 2).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
lngRow = 4 'Zeile auf 4
For Each objFile In objSubSubFolder.Files 'StdZettel durchlaufen
If Right(objFile.Name, 5) Like "*xls*" Then 'Wenn ExcelFile
Set wbkSource = Workbooks.Open(objFile, , True, , , , , , , , False) 'File oeffen
Set wksSource = wbkSource.Worksheets("Tabelle1") 'Verweis auf T1 setzen
wksDest.Cells(lngRow, lngCol).Value = wksSource.Range("D9").Value 'Wert kopieren
wksDest.Cells(lngRow, lngCol).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(lngRow, lngCol + 1).Value = wksSource.Range("J24").Value 'Wert kopieren
wksDest.Cells(lngRow, lngCol + 1).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(lngRow, lngCol + 2).Value = wksSource.Range("S50").Value 'Wert kopieren
wksDest.Cells(lngRow, lngCol + 2).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wbkSource.Close False 'File schliessen ohne Speichern
Set wksSource = Nothing 'Object zerstoeren
Set wbkSource = Nothing 'Object zerstoeren
lngRow = lngRow + 1 'Zeilenweiterschaltung
If lngMaxRow < lngRow Then lngMaxRow = lngRow 'MaxZeile speichern
End If
Next objFile 'naechstes File
End If
Next objSubSubFolder 'naechstes UnterUnterverzeichnis
For lngCount = 1 To lngCol Step 4 'Summe vorbereiten
wksDest.Cells(lngMaxRow + 3, lngCount).Value = "Wochenstunden" 'Benennung in Zelle
wksDest.Cells(lngMaxRow + 3, lngCount).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(lngMaxRow + 4, lngCount).Value = "Überstunden" 'Benennung in Zelle
wksDest.Cells(lngMaxRow + 4, lngCount).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Range(Cells(lngMaxRow + 1, lngCount), Cells(lngMaxRow + 1, lngCount + 1)).Merge 'Zeilen zusammenfügen
wksDest.Cells(lngMaxRow + 1, lngCount).Value = "Gesamtbetrag" 'Bennenung in Zeile
wksDest.Range(Cells(lngMaxRow + 1, lngCount), Cells(lngMaxRow + 1, lngCount + 1)).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
] wksDest.Cells(lngMaxRow + 1, lngCount).Offset(0, 1).Value = _
Application.WorksheetFunction.Sum _
(wksDest.Range(wksDest.Cells(3, lngCount + 2), wksDest.Cells(lngMaxRow, lngCount + 2))) 'Summe in Zelle
wksDest.Cells(lngMaxRow + 1, lngCount + 2).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(lngMaxRow + 1, lngCount + 2).NumberFormat = "#,##0.00 $" 'Euro Formatierung
wksDest.Cells(lngMaxRow + 3, lngCount).Offset(0, 1).Value = _
Application.WorksheetFunction.Sum _
(wksDest.Range(wksDest.Cells(3, lngCount + 1), wksDest.Cells(lngMaxRow, lngCount + 1))) 'Summe in Zelle
wksDest.Cells(lngMaxRow + 3, lngCount + 1).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
wksDest.Cells(lngMaxRow + 4, lngCount).Offset(0, 1).Value = _
wksDest.Cells(lngMaxRow + 3, lngCount).Offset(0, 1).Value - _
wbkDest.Worksheets("Anleitung").Range("D21") 'Ueberstunden rechnen
wksDest.Cells(lngMaxRow + 4, lngCount + 1).BorderAround ColorIndex:=0, Weight:=xlThin 'Rahmen rum
Next lngCount
wksDest.Columns.AutoFit 'Autofit
End If
Next objSubfolder
wbkDest.Worksheets("Anleitung").Activate 'Sheet Anleitung wieder aktivieren
Application.ScreenUpdating = True 'Bildschirm ein
'Objecte zerstoeren
Set wbkDest = Nothing
Set wksDest = Nothing
Set objFSO = Nothing
Set objFolder = Nothing
Se