Gegevens van meerder regels samenvoegen op een regel

[hryttel]

Goedenavond,

Ik heb een document met meer dan 80000 regels. Hiervan zijn er 3500 namen uniek.
Voor elk relatie die deze namen hebben is er een regel gebruikt.
Ik wil graag dat per naam alle relaties op een regel komt en een relatie per kolom.

Bekijk bijlage Mijn Test meerder contacten op zelfde regel.xlsx

Mvg,
Henning

 

[VenA]

Wat is de verwachte uitkomst? Wie is de relatie de DEALER_NAME of het SP_NO?

 

[HSV]

Laat het maar eens lopen.

Resultaat in blad2.

Sub hsv()
Dim sn, i As Long, j As Long, a As Long, n As Long
sn = Sheets("blad1").Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
  ReDim arr(UBound(sn), 0) As String
  For i = 2 To UBound(sn)
   .Item(sn(i, 1)) = .Item(sn(i, 1)) & sn(i, 2) & "_"
  Next i
    For i = 0 To .Count - 1
    a = 0
       arr(0, UBound(arr, 2)) = .keys()(i)
          For j = 1 To UBound(Split(.Item(.keys()(i)), "_"))
           arr(j, UBound(arr, 2)) = Split(.Item(.keys()(i)), "_")(j - 1)
          a = a + 1
          Next j
        ReDim Preserve arr(UBound(sn), UBound(arr, 2) + 1)
          If n < a Then n = a
     Next i
   Sheets("blad2").Cells(1).Resize(.Count, n) = Application.Transpose(arr)
   Sheets("Blad2").Columns.AutoFit
End With
End Sub

 

[hryttel]

Zo Harry, dat hebt je snel gedaan! :thumb:
Top dank je wel.

Opgelost

Groeten,
Henning

 

[hryttel]

Goedemorgen Harry,

Ik heb net je mooie VBA uitgeprobeerd in het originele bestand, daarbij krijg ik de volgende melding:

Heb je daar een verklaring voor

Groeten,
Henning

 

[hryttel]

Goedemorgen Harry,

Ik ben eruit! ik heb het bestand verwerkt met een interval van ± 5000 regels en dat werkt.
Nogmaals bedankt.

Groeten,
Henning

 

[HSV]

Hallo Henning,

Misschien kun je een fictief bestandje maken met zoveel gegevens; kunnen we eens zien van het hoe en waarom.

 

[hryttel]

Hallo Harry,

Hierbij een fictief bestandje met ± 15000 regels
Ter info: ik werk met Windhoos 7 en office 10
Duo processor 2.66 GHz met 4 GB geheugen 32 bits
Bekijk bijlage Mijn Test meerder contacten op zelfde regel.xlsb

Groeten,
Henning

 

[HSV]

Hallo Henning,

Helaas heb ik ook onvoldoende geheugen bij het uitvoeren van de code met de dictionary methode.

Met onderstaande code kom ik tot een dikke 14500 rijen aan gegevens (waar het omslagpunt ligt weet ik niet precies, maar net niet de 15000) met een snelheid van ± 16 seconden.

Test het eens op jouw pc.

Sub hsvtwee()
Dim sn, i As Long, ii As Long, z As Long, s As Long, a As Long, c00 As String, t As Single
t = Timer
sn = Blad1.Cells(1).CurrentRegion
ReDim arr(UBound(sn), UBound(sn)) As String


For i = 1 To UBound(sn)
    s = 0
    If InStr(c00, sn(i, 1) & "|") = 0 Then
              c00 = c00 & sn(i, 1) & "|"
              arr(z, 0) = sn(i, 1)
         For ii = i To UBound(sn)
            If sn(ii, 1) = sn(i, 1) Then
                       s = s + 1
               arr(z, s) = sn(ii, 2)
             If a <= s Then a = s
           End If
         Next ii
       z = z + 1
    End If
 Next i
Blad2.Cells(1).Resize(UBound(arr), a + 1) = arr
Debug.Print Format(Timer - t, "0.000"); " _hsvtwee"
End Sub

 

[hryttel]

Harry,

Alvast bedankt, ik ga het maandag uitproberen.

Fijn weekend!

Groeten,
Henning

 

[hryttel]

Hallo Harry,

Even wat later dan gepland. ;-)
Op mijn eigen Pc krijg ik gelijk een geheugen fout melding. Op mijn werk Pc deze melding:

Geen man over boord! Zo als ik eerder aangaf heb ik het probleem anders opgelost.
Ik wil je toch dit laten weten en je bedanken voor je inspanning. :thumb:

Groeten,
Henning