Achso hatte mich da vertan. Jetzt passt es für Excel 2007 (Dateiendungen) etc, und mein Pfad ist raus. Falls es andere als .xlsx Datein sind, dass in Zeile 35 und 39 anpassen.
Gruß
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 = " " 'hier den Pfad eingeben
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 & "\*.xlsx") 'suche nimmt den Dateinamen auf
Do Until suche = ""
If Left(suche, 6) = "Anonym" And Right(suche, 9) = "2015.xlsx" Then 'könnte man noch ausbauen
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
|