So habe ich es versucht anzupassen. Leider mit Fehler. Danke für die Hilfe
Option Explicit
Sub berechnenLP()
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", "POS")
pfad = "Pfad"
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) & " [€/MW]"
Workbooks(name).Worksheets(1).Cells(1, 3 + (i - 1) * 3) = "Min " & bedingungen(i) & " [€/MW]"
Workbooks(name).Worksheets(1).Cells(1, 4 + (i - 1) * 3) = "Mittwelwert " & bedingungen(i) & " [€/MW]"
Next i
zeile = 2
suche = Dir(pfad & "\*.xlsx")
Do Until suche = ""
If Left(suche, 13) = "ERGEBNISLISTE" Then
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))
If anzahl = 0 Then
mitwe = 0
Else
mitwe = summe / anzahl
End If
formel1 = "=SVERWEIS(" & Chr(34) & bedingungen(i) & "*" & Chr(34) & ";B1:C5100;2;FALSCH)"
Workbooks(name2).Worksheets(1).Columns("B:C").Sort Key1:=Workbooks(name2).Worksheets(1).Range("C1"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Workbooks(name2).Worksheets(1).Cells(1, 4).FormulaLocal = formel1
max = Worksheets(1).Cells(1, 4).Value
Workbooks(name2).Worksheets(1).Columns("B:C").Sort Key1:=Workbooks(name2).Worksheets(1).Range("C1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Workbooks(name2).Worksheets(1).Cells(1, 5).FormulaLocal = formel1
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