große Datenmenge zuordnen / Array???

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub xxx() Dim arr1 Dim arr2 Dim z As Long Dim X As String arr1 = Cells(1, 1).CurrentRegion.Value ReDim arr2(1 To UBound(arr1, 1), 1 To 1) For z = UBound(arr1, 1) To 2 Step -1 X = arr1(z, 2) & ", " & X If arr1(z, 1) arr1(z - 1, 1) Then arr2(z, 1) = Left(X, Len(X) - 2) X = "" End If Next X = arr1(1, 2) & ", " & X arr2(1, 1) = Left(X, Len(X) - 2) Cells(1, 3).Resize(UBound(arr2, 1), 1) = arr2 End Sub

Hallo Daniel,
vielen Dank für deine Antwort. Das Makro läuft super und auch in einer wahnsinnigen Geschwindigkeit.
Allerdings würde mich die Lösung über ein Dictionary trotzdem noch interessieren (rein Interesse halber)
Mein ursprünglicher Code sah wie folgt aus:
letzteZeile = Cells(1, 1).End(xlDown).Row
For I = 2 To letzteZeile
a = 1
auftrag_Kopie = Range("A" & I).Value
auftrag_Kopie1 = Range("A" & I + 1).Value
auftrag_Kopie2 = Range("A" & I - 1).Value
If auftrag_Kopie = auftrag_Kopie2 Then
Else
Zusammenfassung = Range("B" & I).Value
Range("C" & I).Value = Zusammenfassung
Do Until auftrag_Kopie auftrag_Kopie1
Zusammenfassung = Zusammenfassung & ", " & Range("B" & I + a).Value
Range("C" & I).Value = Zusammenfassung
a = a + 1
auftrag_Kopie1 = Range("A" & I + a).Value
Loop
End If
Next

Sub Test_Dic() Dim dic As Object Dim arr1, arr2 Dim z As Long arr1 = Cells(1, 1).CurrentRegion.Value ReDim arr2(1 To UBound(arr1, 1), 1 To 1) Set dic = CreateObject("Scripting.dictionary") For z = 1 To UBound(arr1, 1) dic(arr1(z, 1)) = dic(arr1(z, 1)) & ", " & arr1(z, 2) Next For z = 1 To UBound(arr1, 1) arr2(z, 1) = Mid(dic(arr1(z, 1)), 3) dic(arr1(z, 1)) = "" Next Cells(1, 4).Resize(UBound(arr2, 1), 1) = arr2 End Sub

Hallo,
im Sinne eines kleinen Rennens habe ich einen entsprechenden Code mit dictionary geschrieben.
Das Ergebnis: Daniels code (den ich nicht so richtig verstehe) ist 4 x schneller.
Das Setting:


Sub anlegen()
ActiveSheet.Cells.Clear
For i = 1 To 10000
lr = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(Cells(lr, "A"), Cells(lr, "A").Offset(4)) = i
Range(Cells(lr, "B"), Cells(lr, "B").Offset(4)) = Application.Transpose(Array(1, 2, 3, 4, 5) _
)
Next i
Range("A1:B1") = Array(1, 23)
End Sub
Sub Daniel()
Anf = Timer
Dim arr1
Dim arr2
Dim z As Long
Dim X As String
arr1 = Cells(1, 1).CurrentRegion.Value
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)
For z = UBound(arr1, 1) To 2 Step -1
X = arr1(z, 2) & ", " & X
If arr1(z, 1)  arr1(z - 1, 1) Then
arr2(z, 1) = Left(X, Len(X) - 2)
X = ""
End If
Next
X = arr1(1, 2) & ", " & X
arr2(1, 1) = Left(X, Len(X) - 2)
Cells(1, 3).Resize(UBound(arr2, 1), 1) = arr2
Debug.Print "Daniel", Timer - Anf
End Sub
Sub Fen()
Anf = Timer
lr = Cells(Rows.Count, "A").End(xlUp).Row
F0 = Range("A1:B" & lr)
With CreateObject("scripting.dictionary")
For i = 1 To lr
If Not .exists(Cells(i, "A").Value) Then
.Add (F0(i, 1)), F0(i, 2)
Else
.Item(F0(i, 1)) = .Item(F0(i, 1)) & ", " & F0(i, 2)
End If
Next i
Cells(1, 4).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
Debug.Print "Fen", Timer - Anf
End Sub

mfg

Beliebteste Forumthreads (12 Monate)

große Datenmenge zuordnen / Array???

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread