Sverweis mit Mehrfachtreffern | Ergebnis in einer Zelle erhalten
#21
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:
  • derOlli
Top
#22
Hallo atilla,

Hab die versteckte Entwicklertools gefunden Smile

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

Vielen Dank Smile
Top
#23
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.





Top
#24
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
Top
#25
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
Top
#26
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
Top
#27
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
Top
#28
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
Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 3 Gast/Gäste