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