Hallo ihr :)
Ich hab da mal ein Problem und bekomme es nicht so ganz unter Kontrolle. Ich versuche einen gewichteten Durchschnitt in einer Tabelle zu berechen, das ganze in VBA. Soweit auch kein Problem, aber:
Es handelt sich um eine Tabelle auf der mehrere Filter liegen und ich bekomme es nicht hin, dass er mit nur die summiert, die angezeigt werden. Aktuell sieht das ganze so aus:
Sub WartungGT()
Dim DI As Worksheet
Dim i As Integer
Dim ZeilenAnzahl As Double
Dim ZwSp As Double
Dim Prod As Double
Dim GewD As Double
Set DI = Sheets("Datenimport")
i = 1
With ThisWorkbook.Worksheets("Datenimport")
ZeilenAnzahl = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Count
End With
Prod = 0
For i = 1 To ZeilenAnzahl + 1
If DI.Cells(i + 1, 7).Hidden = False Then
Prod = Prod + DI.Cells(i + 1, 7) * DI.Cells(i + 1, 9)
End If
Next i
GewD = Prod / WorksheetFunction.Sum(Range(Cells(2, 9), Cells(ZeilenAnzahl + 1, 9)))
Dabei kommt aber Raus: " Laufzeitfehler '1004': Die Hidden-Eigenschaft des Range-Objektes kann nicht zugeordnet werden.
Soweit ich das verstehe heißt das ja im Endeffekt, dass die Hidden-Eigenschaft nicht auf die Anzeige durch Autofilter bezogen ist... oder?
Ein anderer Versuch für die Berechnung sah so aus:
'ZwSp = Application.WorksheetFunction.SumProduct(Range("G2:G" & ZeilenAnzahl + 1), Range("I2:I" & ZeilenAnzahl + 1))
'DI.Cells(ZeilenAnzahl + 2, 9).Value = ZwSp / DI.Cells(ZeilenAnzahl + 2, 7).Value
Aber hier kam eine "Überlauf" Fehlermeldung.
Eine Berechnung über Excel(auch nicht in Hilfsspalten) kommt nicht in Frage, auch wenn es damit sicherlich deutlich einfacher wäre.
Habt ihr eine Idee? Im Endeffekt brauche ich ja nur die IF-Abfrage zum funktionieren bringen, aber mir gehen hier die Ideen aus... =/
Die anderen Variablen werden auch in dem Makro verwendet, also nicht wundern. Ich hab den hier eingefügten Code mal auf das wesentliche begrenzt.
Schonmal vielen Dank =)
Gruß
Max
Auch hier könnte man Arrays einsetzen. Dim a1, a2, i&, v#, r1 As Range, r2 As Range, c As Range
Set r1 = Range(Range("A2"), Range("A2").End(xlDown)).SpecialCells(xlCellTypeVisible)
Set r2 = Range(Range("I2"), Range("I2").End(xlDown)).SpecialCells(xlCellTypeVisible)
If Not r1 Is Nothing And Not r2 Is Nothing Then
If r1.Count <> r2.Count Then
MsgBox "Bereiche sind nicht gleich groß."
Exit Sub
End If
ReDim a1(1 To r1.Count): ReDim a2(1 To r1.Count)
For Each c In r1
i = i + 1
a1(i) = c.Row
Next
i = 0
For Each c In r2
i = i + 1
a2(i) = c.Row
Next
'wenn der Speicher knapp ist
'Set r1 = Nothing
'Set r2 = Nothing
For i = 1 To UBound(a1)
v = v + a1(i) * a2(i)
Next
MsgBox v / UBound(a1)
End If
Hallo Lachtaube,
Arrays und ich sind seid gestern noch nicht so ganz firm miteinander... Aber ich bin recht beeindruckt wie schnell man mit diesen Daten verarbeiten kann.
Zu meiner Frage, ich habe den Code bei mir eingepflegt, jedoch machen die Werte die rauskommen nicht so ganz Sinn und meine Kollegin und ich haben beide Stellenweise keine Ahnung was da eigentlich im Code passiert. Zum Beispiel wofür die Variable C ist und was in Ihr drin steht.
Ich habe die Range Set r1 etc. angepasst an die Spalten, sonst nichts weiter verändert. Wenn ich nun eine Berechnung mit meiner Tabelle durchführe komme ich auf 6stellige Beträge - Aber eigentlich müsste ein % Wert rauskommen (bzw. 0,...)
Im Anhang habe ich eine Testtabelle angehangen, hier kommen als Ergebnis 6,5 raus. Es sollten aber 0,157 bzw 15,7% sein. → Außer mein Mathe lässt mich grade vollends im Stich, kommt ab und an auch mal vor ;D
Leider hab ich keine Ahnung wo es hängt... Kannst du mir sagen an welcher Schraube ich drehen muss?
Trotzdem schonmal vielen Dank =) Ich schau selber auch nochmal parallel ob ich es selbst hinbekomme, aber wir sitzen hier mit ratlosen Gesichtern.^^
Viele Grüße
Max
Sorry, statt c.Row muss es natürlich c.Value heißen. Und die Berechnung war auch falsch. :(
Sub test2()
Dim a1, a2, i&, v#, vs#, r1 As Range, r2 As Range, c As Range
Set r1 = Range(Range("G2"), Range("G2").End(xlDown)).SpecialCells(xlCellTypeVisible)
Set r2 = Range(Range("I2"), Range("I2").End(xlDown)).SpecialCells(xlCellTypeVisible)
If Not r1 Is Nothing And Not r2 Is Nothing Then
If r1.Count <> r2.Count Then
MsgBox "Bereiche sind nicht gleich groß."
Exit Sub
End If
ReDim a1(1 To r1.Count): ReDim a2(1 To r1.Count)
For Each c In r1
i = i + 1
a1(i) = c.Value
Next
i = 0
For Each c In r2
i = i + 1
a2(i) = c.Value
Next
'wenn der Speicher knapp ist
'Set r1 = Nothing
'Set r2 = Nothing
For i = 1 To UBound(a1)
v = v + a1(i) * a2(i)
vs = vs + a1(i)
Next
MsgBox Format$(v / vs, "Percent")
End If
End Sub
a1, a2 sind die beiden Arrays. In v wird das Summenprodukt ermittelt und in vs werden die Nachträge aufaddiert.
Es funktioniert, wie genial =)
Vielen vielen Dank Lachtaube, jetzt schon das 2. mal in Folge!!
Werde mich sobald ich hier alles fertig und abgeschlossen hab mal in die Array Thematik einarbeiten. Könnte noch öfter nützlich sein.
Und nochmal viel Dank, du hast mir jetzt 2 Tage in Folge den Tag gerettet =)
Danke!!