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")
Do Until suche = ""
If Left(suche, 6) = "Anonym" And Right(suche, 8) = "2015.xls" 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))
mitwe = summe / anzahl
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