Schneller mit Dictionary
27.05.2013 14:09:51
Erich
Hi André,
da es dir wohl auch um Geschwindigkeit geht, noch eine dritte Variante:
Sub Dict()
Dim lngQ As Long, arrQ, oDic As Object, sTxt As String
Dim zz As Long, nInd As Long, arA()
With Sheets("Auswertung") ' Auswertungszeilen
lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 ' Anz. in Sp. A = 1
arrQ = .Cells(2, 1).Resize(lngQ, 2)
Set oDic = CreateObject("Scripting.Dictionary")
ReDim arA(1 To 22)
For zz = 1 To lngQ
oDic(arrQ(zz, 1) & "#" & arrQ(zz, 2)) = arA
Next zz
End With
With Sheets("Daten") ' Quelldaten
lngQ = .Cells(.Rows.Count, 6).End(xlUp).Row - 33 ' Anz. in Sp. F = 6
arrQ = .Cells(34, 6).Resize(lngQ, 4) ' Quellwerte
For zz = 1 To lngQ
sTxt = arrQ(zz, 1) & "#" & arrQ(zz, 2)
If oDic.Exists(sTxt) Then
arA = oDic(sTxt)
For nInd = Application.RoundUp(48 * arrQ(zz, 3), 0) - 13 _
To Application.RoundUp(48 * arrQ(zz, 4), 0) - 14
arA(nInd) = arA(nInd) + 1 ' Weiterzählen
Next nInd
oDic(sTxt) = arA
End If
Next zz
End With
arrQ = oDic.Items ' restl. Daten (Array)
ReDim arA(oDic.Count - 1, 1 To 22)
For zz = 0 To oDic.Count - 1 ' Übertrag in 1 Array
For nInd = 1 To 22
arA(zz, nInd) = 0 + arrQ(zz)(nInd)
Next nInd
Next zz
With Sheets("Auswertung") ' Ausgabe in Zielblatt
.Cells(2, 3).Resize(oDic.Count, 22) = arA
End With
End Sub
In dieser Mappe können die drei Varianten mit einem Zeitvergleich gestartet werden:
https://www.herber.de/bbs/user/85543.xlsm
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich