Hallo alle VBA Helfer,
ich habe hier nochmal zu einem alten Skript eine Frage, die ich schonmal gestellt habe und eigentlich dachte es hätte mir schon die richtigen Werte geliefert.
In dem folgenden Code will ich aus verschiedenen Datein jeweils den Mittel-, Max- Und Minimalwert berechnen und in eine Tabelle zusammenfassen. Dabei stehen die Bedingungen in Spalte B und die auszuwertenden Daten in Spalte C. Soweit hat alles geklappt.
Jetzt habe ich versucht, Daten aus aus Spalte D, Bedingungen bleiben in B, auszuwerten und jetzt in Tabellenblatt 2 darzustellen. Hierbei treten leider einige Probleme auf. Vielleicht seht ihr den Fehler
Option Explicit
Sub berechnenAP()
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 = "C:\Users\" '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 2
Workbooks(name).Worksheets(2).Cells(1, 2 + (i - 1) * 3) = "Max " & bedingungen(i) & " [€/MW]"
Workbooks(name).Worksheets(2).Cells(1, 3 + (i - 1) * 3) = "Min " & bedingungen(i) & " [€/MW]"
Workbooks(name).Worksheets(2).Cells(1, 4 + (i - 1) * 3) = "Mittwelwert " & bedingungen(i) & " [€/MW]"
Next i
zeile = 2
suche = Dir(pfad & "\*.xlsx") 'suche nimmt den Dateinamen auf
Do Until suche = ""
If Left(suche, 13) = "ERGEBNISLISTE" Then 'könnte man noch ausbauen
Workbooks.Open pfad & "\" & suche
name2 = ActiveWorkbook.name
For i = 1 To 2
'=ZÄHLENWENN(A1:A7;"pos*")
anzahl = Application.WorksheetFunction.CountIf(Workbooks(name2).Worksheets(1).Columns(2), bedingungen(i) & "*")
'=SUMMEWENN(A1:A7;"pos*";B1:B7)
summe = Application.WorksheetFunction.SumIf(Worksheets(1).Columns(2), bedingungen(i) & "*", Worksheets(1).Columns(4))
If anzahl = 0 Then
mitwe = 0
Else
mitwe = summe / anzahl
End If
'Spalte B Bedingungen, Spalte C Werte
'=SVERWEIS("neg*";A1:B7;2;FALSCH)
formel1 = "=SVERWEIS(" & Chr(34) & bedingungen(i) & "*" & Chr(34) & ";B1:D8000;2;FALSCH)"
Workbooks(name2).Worksheets(1).Columns("B:D").Sort Key1:=Workbooks(name2).Worksheets(1).Range("D1"), 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:D").Sort Key1:=Workbooks(name2).Worksheets(1).Range("D1"), 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(2).Cells(zeile, 4 + (i - 1) * 3) = mitwe
Workbooks(name).Worksheets(2).Cells(zeile, 3 + (i - 1) * 3) = min
Workbooks(name).Worksheets(2).Cells(zeile, 2 + (i - 1) * 3) = max
Next i
Workbooks(name2).Close savechanges:=False
Workbooks(name).Worksheets(2).Cells(zeile, 1) = suche
zeile = zeile + 1
End If
suche = Dir()
Loop
Workbooks(name).Worksheets(2).Range("A:M").Columns.AutoFit
Workbooks(name).Worksheets(2).Range("A:M").HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
Vielen Dank
Gruß Sdeluxe
|