meerdere waarden bij 1 zoekterm ordenen.

[Depant]

Hallo allemaal,

Voor mij is dit een lastig klusje. ( onmogelijke klus)
In kolom a staat een lijst met monsternummers. ( met veel duplo, triplo ed, dus dezelfde nummers)
Graag wil ik de waarden die bij die monsternummers horen horizontaal geordend achter kolom "G" krijgen.
Er kunnen dus 2, 3 of vier waarden bij horen.
De lijst is 100000 monsters lang.
Maar omwille van de duidelijkheid heb ik een klein voorbeeld gemaakt....

Bij voorbaat dank...

 

[OctaFish]

Ik had al een oplossing bedacht voor je eerste bestandje, dus die zal ik voor de volledigheid maar meeposten . Hierin heb ik de data anders neergezet, want op deze manier werd het nogal lastig. Door alles in een tabel in te voeren, kun je namelijk een draaitabel maken. En dan ben je gelijk klaar. Dus terwijl jij deze bekijkt, pak ik de nieuwe er even bij .

 

[OctaFish]

Daar ben ik dan snel klaar mee, want veel verschil zie ik niet . Mijn 'oplossing' blijft in ieder geval hetzelfde!

 

[Timshel]

En anders wellicht deze:

Sub tsh()
    Dim Br, Bs
    Dim i As Long, j As Long, k As Long, m As Long, t As Long
    
    Br = Sheets("Blad1").Cells(2, 1).CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(Br)
            .Item(Br(i, 1)) = .Item(Br(i, 1)) + 1
        Next
        m = Application.Max(.Items)
        ReDim Bs(1 To .Count, 1 To m * (UBound(Br, 2) - 1) + 2)
        For i = 2 To UBound(Br)
            k = Application.Match(Br(i, 1), .Keys, 0)
            Bs(k, 1) = Br(i, 1)
            t = Bs(k, UBound(Bs, 2)) + 1
            For j = 2 To UBound(Br, 2)
                Bs(k, 1 + (j - 2) * m + t) = Br(i, j)
            Next
            Bs(k, UBound(Bs, 2)) = t
        Next
        Sheets("Blad1").Cells(3, 7).Resize(.Count, UBound(Bs, 2) - 1) = Bs
    End With
End Sub

 

[Depant]

Pure magie!!!
Helpmij.nl moet eeuwig blijven.:thumb:

Bedankt samen!!

 

[Gijsbert1]

Vraag is al opgelost maar toch;

Ik was aan het proberen zonder draaitabel en zonder VBA.
zie voorbeeld: Bekijk bijlage beter_2.xlsx

Methode:
dynamisch gedefinieerde gebieden I.C.M. met Matrix formules index/vergelijken

 

[Excelbat]

Hi Timshel,

Probeer jouw code te ontleden om er wat van te leren:

k = Application.Match(Br(i, 1), .Keys, 0)

Kan jij bij bovenstaande code uitleg geven wat 'ie doet? Application.match zal ongetwijfeld de excelfunctie 'vergelijken' zijn.
Hij vergelijkt de waarde Br(i,1) in .Keys, en dat moet dan een exacte overeenkomst zijn vanwege de 0.

Mijn vraag is dus: wat zijn keys? Is dat een array met waarden? Kan ik deze keys op de één of andere manier zichtbaar krijgen?

Thanx and greetz/Excelbat

 

[Timshel]

@Excelbat.
.Keys is een array met sleutelwaarden van het Dictionary-object. De dictionary is een handig hulpmiddel om unieke waarden uit een bereik te verkrijgen.
snb heeft op zijn site een pagina gewijd aan dit onderwerp: http://www.snb-vba.eu/VBA_Dictionary_en.html.

 

[snb]

of met cel A1 gevuld

Sub M_snb()
    sn = Sheet1.Cells(1).CurrentRegion
    ReDim sp(0, 4 * (UBound(sn, 2) - 1))
    
    With CreateObject("Scripting.Dictionary")
        For j = 2 To UBound(sn)
           sq = sp
           If .exists(sn(j, 1)) Then sq = .Item(sn(j, 1))
           sq(0, 0) = sn(j, 1)
           
           For jj = 1 To UBound(sq, 2)
             If sq(0, jj) = "" Then
                 For jjj = 2 To 5
                   sq(0, jj + 4 * (jjj - 2)) = sn(j, jjj)
                 Next
                 
                .Item(sn(j, 1)) = sq
                Exit For
             End If
          Next
        Next
        
        Sheets("Blad1").Cells(2, 7).Resize(.Count, UBound(sp, 2) + 1) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[Excelbat]

Bedankt SNB, ga ik van het weekend ook 'ns mee puzzelen.

Greetz/Excelbat