Sverweis mit Mehrfachtreffern | Ergebnis in einer Zelle erhalten

[atilla]

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.

[derOlli]

Hallo atilla,

Hab die versteckte Entwicklertools gefunden

Ich muss jetzt erstmal zu einem Kunden raus fahren - versuche das später umzusetzen.

Vielen Dank

[Ego]

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.

[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

[atilla]

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.

[derOlli]

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

[derOlli]

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

[stephaan]

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