Hallo,
der Vollständigkeit halber mal der aktuelle Code, der alle Workbooks im aktuellen Verzeichnis durchläuft und die in Spalte C notierten Kategorien mit in Spalte B notierter Anzahl zusammenzählt, pro Datei und Tabelle:
' Fasse Daten aus allen Workbooks dieses Ordners zusammen
Sub DatenZusammenfassen()
' setzt aktuellen Pfad in diesem Ordner (inkl. Backslash am Ende)
Pfad = ActiveWorkbook.Path & "\" 'FileSystem.CurDir & "\"
' Lese ersten Dateinamen/Ordnernamen
Dateiname = Dir(Pfad)
' Wir starten die Ausgabe in Zeile 3
OutputRow = 3
' Lösche vorhandene Daten in Ausgabetabelle ab 1,4 2,3 und alles ab Zeile 3
range(Cells(1, 4), Cells(1, UsedRange.Columns.Count)).Value = ""
range(Cells(2, 3), Cells(2, UsedRange.Columns.Count)).Value = ""
range(Cells(3, 1), Cells(UsedRange.Rows.Count, UsedRange.Columns.Count)).Value = ""
' Schreib mal Datum und Uhrzeit in Zeile 1
range("B1").Value = "fasse Daten zusammen"
range("C1").Value = Date
range("D1").Value = Time
' Durchlauf Dateinamen
While Dateiname <> ""
' Filterkriterium (Exceldatei, nicht die aktuelle Datei)
If DateinameCheck(Dateiname) = "ok" Then
' öffne Workbook
Workbooks.Open (Pfad & Dateiname)
Debug.Print "opened " & Dateiname
' Dateiname kommt in erste Spalte
range("A" & OutputRow).Value = Dateiname
' Setze Variable auf Worksheetsliste dieses Workbooks
Set actualWorksheets = Workbooks(Dateiname).worksheets
' Durchlaufe Worksheets
For Each ws In actualWorksheets
' Schreibe Tabellennamen in B-Spalte
range("B" & OutputRow).Value = ws.Name
' Lasse die Spalten durchlaufen
SpaltenDurchlaufen ws, OutputRow
' nächste Zeile für neuen Eintrag
OutputRow = OutputRow + 1
Next
' Workbook wieder zumachen
Workbooks(Dateiname).Close
Debug.Print "closed " & Dateiname
End If
' nächsten Dateinamen einlesen
Dateiname = Dir
Wend
End Sub
Function DateinameCheck(Dateiname)
' Dateiname soll nicht diese Datei sein und muss auf .xls enden
If Dateiname <> ThisWorkbook.Name _
And Right(Dateiname, 4) = ".xls" Then
DateinameCheck = "ok"
Else
' das macht man wohl besser mit boolean
DateinameCheck = "notok"
End If
End Function
Function SpaltenDurchlaufen(ws, OutputRow)
Debug.Print "--->" & ws.Name
' Durchlaufe die Spalte B im aktuellen Tabellenblatt
For Each mycell In ws.range("B1:B" & ws.UsedRange.Rows.Count)
' Flag setzen, Kategorie noch nicht vorhanden in Ausgabetabelle
CategoryFound = "notfound"
'in 0 umwandeln, wenn da Text drinne steht
myvalue = mycell.Value
If VarType(myvalue) = 8 Then
myvalue = 0
End If
'nur wenn was in Spalte C steht
If ws.range("C" & mycell.Row).Value <> "" _
And ws.range("C" & mycell.Row).Value <> " " _
And myvalue <> 0 Then
' schaue in Ausgabetabelle Zeile 2 ab Spalte 5 ob Kategorie schon gelistet
For Each myAusgabeCell In range(Cells(2, 5), Cells(2, UsedRange.Columns.Count))
'natürlich nur, wenn nicht schon gefunden
If Trim(myAusgabeCell.Value) = Trim(ws.range("C" & mycell.Row).Value) Then
' wenn also Kategorie stimmt, dann addiere den Wert mit dem Zellenwert
Cells(OutputRow, myAusgabeCell.Column).Value = _
Val(Cells(OutputRow, myAusgabeCell.Column).Value) + myvalue
' Flag gefunden setzen
CategoryFound = "found"
Exit For
End If
Next
' falls Kategorie noch nicht gelistet und der Wert nicht 0/String (s.o.) ist
If CategoryFound = "notfound" And myvalue <> 0 Then
' schreibe Spaltenzahl in erste Zeile
Cells(1, UsedRange.Columns.Count + 1).Value = UsedRange.Columns.Count + 1
' schreibe neue Kategorie in zweite Zeile
Cells(2, UsedRange.Columns.Count).Value = Trim(ws.range("C" & mycell.Row).Value)
' setze Wert in aktuelle Zeile
Cells(OutputRow, UsedRange.Columns.Count).Value = myvalue
End If
End If
Next
End Function
Private Sub losjetzt_Click()
DatenZusammenfassen
End Sub
Gruß
jobo