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
|