summewenns/zählenwenns via dictionary

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Formeln() ' Formeln Makro Dim wks1 As Worksheet Dim wks2 As Worksheet, rng2 As Range Dim ZeileL1 As Long, ZeileL2 As Long Dim strFormel As String Set wks1 = Worksheets("Tabelle1") Set wks2 = Worksheets("Tabelle2") With wks2 ZeileL2 = .Cells(.Rows.Count, 1).End(xlUp).Row Set rng2 = .Range(.Cells(2, 3), .Cells(ZeileL2, 3)) End With Application.Calculation = xlCalculationManual Application.ScreenUpdating = False With wks1 ZeileL1 = .Cells(.Rows.Count, 1).End(xlUp).Row strFormel = "=COUNTIFS('" & .Name & "'!R2C1:R" & ZeileL1 & "C1,RC[-2],'" _ & .Name & "'!R2C2:R" & ZeileL1 & "C2,RC[-1])" rng2.FormulaR1C1 = strFormel strFormel = "=SUMIFS('" & .Name & "'!R2C3:R" & ZeileL1 & "C3,'" _ & .Name & "'!R2C1:R" & ZeileL1 & "C1,RC[-3],'" & .Name & "'!R2C2:R" _ & ZeileL1 & "C2,RC[-2])" rng2.Offset(0, 1).FormulaR1C1 = strFormel End With With wks2 .Calculate With .Range(.Cells(2, 3), .Cells(ZeileL2, 4)) .Value = .Value End With End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Hallo Franz,
vielen Dank für deine schnelle Antwort! Ich habe den Code in meine Beispielmappe eingefügt und die Zeilenanzahl dort mal auf ca. 10000 in beiden Blättern erhöht. Dann dauert der Code schon recht lange. Und mein Rechner macht wieder diese bedrohlichen Geräusche, als würde er gleich abstürzen...
Die echte Tabelle macht über 10-20.000 Zeilen diese Berechnungen und zwar gleich ca. 20 auf einen Schlag. Ich lese täglich neue Datensätze ein und alle 20 Summewenns/zählenwenns-Berechnungen werden dann gleichzeitig ausgeführt. Ich hatte schonmal mit dictionaries zu tun. Ist aber lange her und ich bekomme das nicht mehr hin. Es lief aber super schnell auch für diese Anzahl an Berechnungen. (War damals was anderes, aber ähnlich.)
Gibt es wohl die Möglichkeit, diese Berechnungen ebenfalls mit dicts zu lösen und wird das auch schnell und problemlos berechnet werden können?
Gibst du mir Recht, dass dein Code für großen Datenmengen nicht so geeignet ist oder brauche ich einfach nen neuen Rechner? ;-)
Viele Grüße,
Melanie

Hallo Melanie,
große Datenmengen erfordern nun mal ihre Bearbeitungszeit.
hier eine Lösung, die die Auswertungen per Datenarrays macht.
Sie ist etwa 3 mal so schnell wie die Formellösung. Auf meinem Rechner mit 5500 Zeilen in Tabelle 2 und den 6300 in Tabelle1 war die Rechenzeit ca. 3 bis 4 Sekunden mit Formeln ca. 12.
Die Geräusche von deinem Rechner kommen wahrscheinlich vom Kühler der CPU des Rechners, der bei dieser Menge an Berechnungen mal an seine Leistungsgrenze und somit ins Schwitzen kommt.
Wenn die anderen Auswertungen ähnlich sind (Summieren/Zählen wenn ID1 und ID2 übereinstimmen), dann solltest du den Vorschlag mit der Pivottabelle mal in Betracht ziehen. Auswertezeit: Sekundenbereich.
Ob man mit dem Dictionary-Object noch schneller vorankommt?
Gruß
Franz

Sub Auswertung2()
' Auswertung Makro
Dim wks1 As Worksheet
Dim wks2 As Worksheet, rng2 As Range
Dim ZeileL1 As Long, ZeileL2 As Long, Zeile1 As Long, Zeile2 As Long
Dim strFormel As String
Dim arrData1, arrData2, arrResult() As Double
Dim Key1() As String, Key2() As String
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With wks1
ZeileL1 = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData1 = .Range(.Cells(1, 1), .Cells(ZeileL1, 3)).Value
ReDim Key1(1 To ZeileL1)
'ID 1 und ID2 zu einem Schlüsser zusammenfügen
For Zeile1 = 1 To ZeileL1
Key1(Zeile1) = arrData1(Zeile1, 1) & "|" & arrData1(Zeile1, 2)
Next
End With
With wks2
ZeileL2 = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData2 = .Range(.Cells(1, 1), .Cells(ZeileL2, 2)).Value
ReDim arrResult(2 To ZeileL2, 1 To 2)
ReDim Key2(1 To ZeileL2)
'ID 1 und ID2 zu einem Schlüssel zusammenfügen
For Zeile2 = 2 To ZeileL2
Key2(Zeile2) = arrData2(Zeile2, 1) & "|" & arrData2(Zeile2, 2)
Next
End With
For Zeile2 = 2 To ZeileL2
arrResult(Zeile2, 1) = 0
arrResult(Zeile2, 2) = 0
For Zeile1 = 2 To ZeileL1
If Key1(Zeile1) = Key2(Zeile2) Then
arrResult(Zeile2, 1) = arrResult(Zeile2, 1) + 1
arrResult(Zeile2, 2) = arrResult(Zeile2, 2) + arrData1(Zeile1, 3)
End If
Next Zeile1
Next Zeile2
With wks2
.Range(.Cells(2, 3), .Cells(ZeileL2, 4)) = arrResult
End With
Erase arrData1, arrData2, arrResult, Key1, Key2
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

summewenns/zählenwenns via dictionary

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

summewenns/zählenwenns via dictionary

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread