Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Olli, Formatier die Zielzellen als Text. Dann nutze sicherheitshalber folgenden Code: Code: Sub mach_wieder() Dim i As Long, j As Long Dim lngZ As Long
Dim arr As Variant Dim varK Dim D1 As Object Set D1 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Worksheets("Tabelle1") lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range("A2:B" & lngZ) For i = 1 To UBound(arr) D1(arr(i, 1)) = D1(arr(i, 1)) & "," & arr(i, 2) Next i Range("D2").CurrentRegion.Offset(1, 0).Resize(, Range("D2").CurrentRegion.Columns.Count).ClearContents For Each varK In D1.Keys .Cells(j + 2, 4) = varK .Cells(j + 2, 5) = CStr(Mid(D1(varK), 2)) j = j + 1 Next End With End Sub
Den Code in das ein Modul einfügen. Am besten eine Schaltfläche aus den Formularsteuerelementen in die tabelle einfügen und die Prozedur mach zuweisen.
Gruß Atilla
Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:1 Nutzer sagt Danke an atilla für diesen Beitrag 28
• derOlli
Registriert seit: 07.03.2017
Version(en): 2010
Hallo atilla, Hab die versteckte Entwicklertools gefunden  Ich muss jetzt erstmal zu einem Kunden raus fahren - versuche das später umzusetzen. Vielen Dank
Registriert seit: 21.06.2016
Version(en): 2021
Hallo Olli,
bei bis zu 500.000 Datensätzen würde ich auf jeden Fall auch atillas code einsetzen. Insbesondere wenn die Daten nicht sortiert sind.
Bis vor Kurzem kannte ich den Objekttyp dictonary noch nicht und habe nicht erkannt, dass man ihn hier sinnvoll benutzen kann.
helmut
Für mich ist die Möglichkeit in Excel an Zellen und Bereichen Namen zu vergeben die wichtigste Funktionalität. Sie macht Formeln und den VBA-code verständlicher. Für Makros gilt die Regel: "Nur über benannte Bereiche auf den Inhalt der Zellen zugreifen." Und wofür sind Regeln da? Um nachzudenken bevor man sie bricht.
Registriert seit: 14.04.2014
Version(en): 2003, 2007
08.03.2017, 12:27
(Dieser Beitrag wurde zuletzt bearbeitet: 08.03.2017, 12:27 von atilla.)
Hallo zusammen, bei so viel Daten, kann man noch ein paar PS zulegen: Code: Sub mach_mehr()
Dim i As Long, j As Long Dim lngZ As Long
Dim arr As Variant Dim outArr() Dim varK Dim D1 As Object Set D1 = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False With Worksheets("Tabelle1") lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range("A2:B" & lngZ) For i = 1 To UBound(arr) D1(arr(i, 1)) = D1(arr(i, 1)) & "," & arr(i, 2) Next i .Range("D2:E" & lngZ).ClearContents ReDim outArr(D1.Count - 1, 1) For Each varK In D1.Keys outArr(j, 0) = varK outArr(j, 1) = CStr(Mid(D1(varK), 2)) j = j + 1 Next .Range("D2:E" & D1.Count + 1) = outArr End With Application.ScreenUpdating = True
End Sub
Punkt vor Range und Screenupdating ergänzt
Gruß Atilla
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo, und noch ein Paar PS mehr, nicht viel aber immerhin: Code: Sub mach_noch_mehr()
Dim i As Long, j As Long Dim lngZ As Long
Dim arr, arr2 Dim outArr() Dim varK Dim D1 As Object Set D1 = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False With Worksheets("Tabelle1") lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range("A2:B" & lngZ) For i = 1 To UBound(arr) D1(arr(i, 1)) = D1(arr(i, 1)) & "," & arr(i, 2) Next i .Range("D2:E" & lngZ).ClearContents arr = D1.Keys arr2 = D1.items ReDim outArr(D1.Count - 1, 1) For j = 0 To UBound(arr) outArr(j, 0) = arr(j) outArr(j, 1) = arr2(j) Next
.Range("D2:E" & D1.Count + 1) = outArr End With Application.ScreenUpdating = True
End Sub
Abhängig von der Datenmenge bräuchte man den Umweg über die Arrays nicht gehen, sondern könnte direkt die Keys und Items des Dictionary ausgeben. Das wäre dann die schnellste Methode und würde so gehen: Code: Sub mach_absolut()
Dim i As Long, j As Long Dim lngZ As Long
Dim arr As Variant Dim varK Dim D1 As Object Set D1 = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False With Worksheets("Tabelle1") lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range("A2:B" & lngZ) For i = 1 To UBound(arr) D1(arr(i, 1)) = D1(arr(i, 1)) & "," & arr(i, 2) Next i .Range("D2:E" & lngZ).ClearContents
.Range("D2:E2").Resize(D1.Count + 1) = Application.Transpose(Array(D1.Keys, D1.items)) End With Application.ScreenUpdating = True
End Sub
Wie gesagt, kommt es bei Ausführung des obigen Codes zu einem Laufzeitfehler, wenn zu viele Daten eingelesen werden. Die Grenze ist mir nicht bekannt. Einfach mal austesten.
Gruß Atilla
Registriert seit: 07.03.2017
Version(en): 2010
Hallo Zusammen,
"PS"?
Ich bin die Tage leider ständig unterwegs, ich muss mir das am Wochenende in Ruhe ansehen.
Wollte nur kurz eine "Danke" durchsenden, nicht dass das untergeht!
Würde mich nochmal melden, sollte ich was nicht peilen...
VG derOlli
Registriert seit: 07.03.2017
Version(en): 2010
Hallo nochmal,
tut mir leid - hatte die Tage keine Zeit mir das anzusehen. Gerade eben aber.
Danke nochmal an ALLE!
@ atilla: Den Code aus #21 - der wars! es funktioniert alles, geht ziemlich schnell - alles top.
Danke und Beste Grüße derOlli
Registriert seit: 29.03.2017
Version(en): 2010
Hallo atilla,
großartig!
Vielen Dank für Deine Hilfe. Ich denke ich muss mich auch mal mit VBA beschäftigen.
Schöne Grüße, Stephan
|