Hallo ihr zwei!

Ich glaube ihr schreibt da aneinander vorbei. So wie ich das sehen, stehen in Spalte B die Bedingungen und in C die Werte. Spalte A sollte leer sein. Außerdem interpretiere ich die Angaben von sdeluxe (zugegeben sind die Angaben etwas vage :-D und sollten eigentlich nicht mehr interpretiert werden) so, dass die 4 Bedingungen nicht nur am Anfang stehen sondern auch über die 5000 Zeilen verteilt sind und nun von der Menge des Erscheinen der Bedingung der Min, Max bzw. Mittelwert erfasst werden muss. Also insgesamt pro Darei 12 Werte. Das macht glaube ich der Code nicht so ganz. Will mich da nicht einmischen aber würde es aber evtl. versuchen so zu lösen. Dabei nur den Pfad in dem die ganzen Datein liegen bei Pfad eingeben. Evtl. kann man an dem Code noch was feilen (Abfragen, Sicherheiten, Schnelligkeit) aber zum probieren und drauf aufbauen wäre es noch eine Alternative.

Schönen Abend noch

Option Explicit

Sub berechnen()
Dim name As String
Dim name2 As String
Dim mitwe
Dim max
Dim min
Dim i As Long
Dim bedingungen
Dim pfad As String
Dim suche As String
Dim zeile As Long
Dim summe
Dim formel1
Dim formel2
Dim anzahl As Long

bedingungen = Array("", "NEG_HT", "NEG_NT", "POS_HT", "POS_NT")

pfad = "C:\Users\ich\Desktop\"  '"Y:\Eigene Dateien\Bearbeitung\bearbeiten\Makro"
If Right(pfad, 1) = "\" Then pfad = Left(pfad, Len(pfad) - 1)

Application.ScreenUpdating = False
name = ThisWorkbook.name

Workbooks(name).Worksheets(1).Cells(1, 1) = "Dateiname"
For i = 1 To 4
    Workbooks(name).Worksheets(1).Cells(1, 2 + (i - 1) * 3) = "Max " & bedingungen(i)
    Workbooks(name).Worksheets(1).Cells(1, 3 + (i - 1) * 3) = "Min " & bedingungen(i)
    Workbooks(name).Worksheets(1).Cells(1, 4 + (i - 1) * 3) = "Mittwelwert " & bedingungen(i)
Next i

zeile = 2
suche = Dir(pfad & "\*.xls")   'x anhängen
  
Do Until suche = ""

        If Left(suche, 6) = "Anonym" And Right(suche, 8) = "2015.xls" Then   'x anhängen und 8
         
            Workbooks.Open pfad & "\" & suche
            name2 = ActiveWorkbook.name
            For i = 1 To 4
                anzahl = Application.WorksheetFunction.CountIf(Workbooks(name2).Worksheets(1).Columns(2), bedingungen(i))
                summe = Application.WorksheetFunction.SumIf(Worksheets(1).Columns(2), bedingungen(i), Worksheets(1).Columns(3))
                mitwe = summe / anzahl
            'Spalte B Bedingungen, Spalte C Werte
                formel1 = "=MAX((B1:B5100=" & Chr(34) & bedingungen(i) & Chr(34) & ")*(C1:C5100))"
                formel2 = "=SVERWEIS(" & Chr(34) & bedingungen(i) & Chr(34) & ";B1:C5100;2;FALSCH)"
                Workbooks(name2).Worksheets(1).Cells(1, 4).FormulaArray = formel1
                max = Worksheets(1).Cells(1, 4).Value
                Workbooks(name2).Worksheets(1).Columns("B:C").Sort Key1:=Workbooks(name2).Worksheets(1).Range("B1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
                Workbooks(name2).Worksheets(1).Cells(1, 5).FormulaLocal = formel2
                min = Worksheets(1).Cells(1, 5).Value
                       
                Workbooks(name).Worksheets(1).Cells(zeile, 4 + (i - 1) * 3) = mitwe
                Workbooks(name).Worksheets(1).Cells(zeile, 3 + (i - 1) * 3) = min
                Workbooks(name).Worksheets(1).Cells(zeile, 2 + (i - 1) * 3) = max
            Next i
           
            Workbooks(name2).Close savechanges:=False
           
            Workbooks(name).Worksheets(1).Cells(zeile, 1) = suche
            zeile = zeile + 1
        End If
  
          
    suche = Dir()
Loop
Workbooks(name).Worksheets(1).Range("A:M").Columns.AutoFit
Workbooks(name).Worksheets(1).Range("A:M").HorizontalAlignment = xlCenter
Application.ScreenUpdating = True

End Sub