Kolommen vullen o.b.v. gelijke waarden in andere kolommen

[lvanderpol]

Hallo,

Helaas kom ik niet uit de volgende Excel uitdaging. Ik heb een lijst met items in kolom A die ieder eigen specificaties hebben in de volgende kolommen. Items waarbij alle specificaties gelijk zijn match ik graag aan elkaar, op zo'n manier dat de elke relatie op een eigen regel komt. Hieronder probeer ik weer te geven wat ik bedoel.

Ik hoop dat iemand een oplossing weet. Ik heb al veel verschillende index match combinaties geprobeerd, maar kom er niet uit.
Alvast veel dank voor het meedenken!

VOORBEELD DATA:

Item	Spec 1	Spec 2	Spec 3	Spec 4
AUTO	10	20	ABC	DEF
BAL	10	30	ABC	GHI
FIETS	10	20	ABC	DEF
HUIS	20	30	JKL	MNO
TAFEL	10	30	ABC	GHI
MOTOR	10	20	ABC	DEF

GEWENSTE UITKOMST

ITEM	RELATIE
AUTO	FIETS
AUTO	MOTOR
BAL	TAFEL
FIETS	AUTO
FIETS	MOTOR
TAFEL	BAL
MOTOR	AUTO
MOTOR	FIETS

 

[Haije]

lvanderpol,

welkom op Helpmij.nl!

Het is een goede gewoonte om een vraag te illustreren aan de hand van een excel voorbeeldbestand dat qua indeling overeenkomt met het echte bestand, maar waar geen "gevoelige" informatie in staat.

 

[lvanderpol]

Beste Haije,

Bedankt.
In de bijlage een deel van het excel bestand. De uiteindelijke lijst waar het om gaat is duizenden regels langer.

Vriendelijke groet,

 

[popipipo]

Kun je wat met deze draaitabel?

 

[lvanderpol]

Beste Popipipo,

Bedankt voor de bijdrage. Helaas moet ik dan nog steeds elke relatie handmatig invullen, en dat zullen enkele tienduizenden regels zijn vrees ik.

 

[Timshel]

Met formules of draaitabellen weet ik het niet maar dit macrootje werkt volgens mij

Sub tsh()
    Dim Br, Bq
    Dim i As Long, j As Long
    
    Br = Sheets(1).Cells(1).CurrentRegion
    ReDim Bq(2 To UBound(Br))
    For i = 2 To UBound(Br)
        Bq(i) = Br(i, 1) & "|"
        For j = 2 To UBound(Br, 2)
            Bq(i) = Bq(i) & Br(i, j) & "-"
        Next
    Next
    With CreateObject("System.Collections.Arraylist")
        .Add Array("ITEM", "RELATIE")
        For i = 2 To UBound(Bq)
            Br = Filter(Bq, Split(Bq(i), "|")(1))
            For j = 0 To UBound(Br)
                If Br(j) <> Bq(i) Then .Add Array(Split(Bq(i), "|")(0), Split(Br(j), "|")(0))
            Next
        Next
        Sheets(2).Cells(1, 1).Resize(.Count, 2) = Application.Index(.ToArray, 0)
    End With
End Sub

Uitvoer op blad 2

 

[lvanderpol]

Beste Timshel,

Bedankt voor deze code. Kan ik deze code zo gebruiken of moet ik daarvoor nog iets aanpassen? Als ik deze probeer te draaien krijg ik namelijk een out of memory melding (terwijl dit een nieuwe pc is met office365)

 

[VenA]

Uit hoeveel rijen bestaat jouw brondata? Duizenden met veel onderlinge relaties kan wel erg veel varianten opleveren. Een nieuwe PC is nietszeggend als je niet vermeldt hoeveel geheugen er in zit en welke processen je nog meer hebt draaien.

In jouw voorbeeldbestand werkt de code van @Timshel ook niet heb je het daarin eerst wel getest?

@Timshel, Jouw code werkt natuurlijk wel, alleen bij mij niet in het voorbeeldbestand. Kolom H is de boosdoener.

 

[lvanderpol]

Ik heb het alleen nog in het voorbeeldbestand getest.

Hoe kan ik het probleem met kolom H oplossen? Ik ben helaas (nog) niet zo thuis in deze codes.


PS. Een nieuwe pc met een 8e generatie i5 processor en 8gb ram is hopelijk toch wel voldoende

 

[VenA]

Als kolom H geen onderdeel is van het bestand en alleen ter verduidelijking is dan kan je deze verwijderen. Maar dit verklaart jouw 'out of memory melding' niet. Dus hoe heb je het toegepast? Laat maar zien in het bestandje.

 

[HSV]

Andere code, ander resultaat.

Sub hsv()
Dim sv, hs, i As Long, ii As Long, y As Long
sv = Cells(1).CurrentRegion
ReDim a(1, 0)
a(0, 0) = "Item"
a(1, 0) = "Gerelateerd item"
 For i = 1 To UBound(sv)
  For ii = 2 To UBound(sv)
   If i <> ii Then
     If Join(Array(sv(i, 3), sv(i, 4), sv(i, 5), sv(i, 6), sv(i, 7)), "|") = Join(Array(sv(ii, 3), sv(ii, 4), sv(ii, 5), sv(ii, 6), sv(ii, 7)), "|") Then
      ReDim Preserve a(1, UBound(a, 2) + 1)
              y = y + 1
        a(0, y) = sv(i, 1)
        a(1, y) = sv(ii, 1)
     End If
    End If
   Next ii
  Next i
  With Cells(3, 15).Resize(y+1, 2)
   .CurrentRegion.ClearContents
   .Value = Application.Transpose(a)
   .Sort Cells(3, 15), , Cells(3, 16), , , , , 1
  End With
End Sub

 

[lvanderpol]

Yes, dit werk. Heel veel dank!