Gegevens uitbreiden

[Lex1972]

Hallo ,

Is het mogelijk om gegevens te dupliceren op basis van twee gegevens (cellen)Bekijk bijlage voorbeeld.xlsx ?
Ik heb diverse fora's afgelopen maar zie geen oplossing voor mijn probleem.
Heb geprobeerd om via macro's het 1 en ander te bereiken maar dat bood geen oplossing.
Handmatig word een hele opgave , vandaar dat ik dit topic hier plaats.

Alle hulp is welkom

Groeten Alex

 

[HSV]

Resultaat op blad2.

Sub hsv()
Dim sn, sq, sq1, i As Long, j As Long, jj As Long, n As Long
sn = Sheets(1).Cells(1).CurrentRegion
ReDim arr(UBound(sn) * 14, 10)
For i = 2 To UBound(sn)
    sq = Split(sn(i, 9), ";")
    sq1 = Split(sn(i, 8), ";")
   For j = 0 To UBound(sq)
        For jj = 0 To UBound(sq1)
            arr(n, 0) = sn(i, 1)
            arr(n, 1) = sn(i, 2)
            arr(n, 2) = sn(i, 3)
            arr(n, 3) = sn(i, 4)
            arr(n, 4) = sn(i, 5)
            arr(n, 5) = sn(i, 6)
            arr(n, 6) = sn(i, 7)
            arr(n, 7) = sq1(jj)
            arr(n, 8) = sq(j)
            arr(n, 9) = sn(i, 10)
            arr(n, 10) = sn(i, 11)
            n = n + 1
         Next jj
   Next j
Next i
    With Sheets(2)
     .Cells(1).Resize(UBound(arr), 11) = arr
     .Columns.AutoFit
    End With
End Sub

 

[Lex1972]

Hartelijk dank Harry ,

Deze formule komt goed in de richting , is het mogelijk om ook de kleuren zeg maar uit te klappen ?
Als dit niet mogelijk is ga ik het met de hand verder uitwerken , je hebt me in ieder geval al een
heel stuk geholpen.

Groet Alex

 

[HSV]

Kleuren uitklappen?
Die moet je eens beter uitleggen.

 

[Lex1972]

Harry ,

Ik bedoel daarmee het volgende :

Nu zorgt de macro ervoor dat alle maten opengeklapt worden , dus van xs;s;n;l;xl;xxl;3xl naar regels onder elkaar.
Echter zijn er dus ook verschillende kleuren beschikbaar zoals in de bovenste regel in het voorbeeld te zien is.
Elke maat is in dit voorbeeld te verkrijgen in de kleuren wit of zwart.

Ik ben in ieder geval hartstikke blij dat je me wilt helpen ,

Groeten Alex

 

[arrie23]

Omdat ik met een soortgelijk probleem zit(zat) heb ik dit topic met interesse gevolgd.
De voorgestelde macro van Harry klapt naast de maten ook de kleuren uit dus volgens mij doet ie al precies wat je wilt

 

[Lex1972]

Bij de laatste kolom zie je dat de kleuren nog achter elkaar staan (havana;Stone Grey) nadat de macro is uitgevoerd.

Groet Alex

 

[arrie23]

In je eerste voorbeeldbestand staat de maat in Kolom H (kolom 8) en de kleur in Kolom I (kolom 9). Hier gaat de macro van uit.
Bij het laatste plaatje staat de maat in kolom I (kolom 9) en de kleur in Kolom J (kolom 10). Dan gaat het dus niet goed. Dus of de macro aanpassen (deze gaat overigens, net als het voorbeeldbestand, uit van 11 kolommen) of nog makkelijker: zorgen dat de maat en kleur in kolom H en I staan (en je maximaal 11 kolommen hebt)

 

[HSV]

Volgens mij zit dat er al netjes in gebakken.
Alle maten per kleur.

Exit: ik zal er vanavond eens naar kijken als niemand anders het doet.
Momenteel aan het werk.

 

[Lex1972]

Ik heb het hele bestand met de macro maar geupload want er gaan nu dingen mis die boven mijn pet gaan :shocked:

 

[arrie23]

Zorg dat er een eerste rij is met kolomkoppen en zorg dat er een (leeg) Blad2 is.

Verander in de code de 14 naar 50 en probeer het nogmaals

Sub hsv()
Dim sn, sq, sq1, i As Long, j As Long, jj As Long, n As Long
sn = Sheets(1).Cells(1).CurrentRegion
ReDim arr(UBound(sn) * [B][COLOR="#FF0000"]50[/COLOR][/B], 10)
For i = 2 To UBound(sn)
    sq = Split(sn(i, 9), ";")
    sq1 = Split(sn(i, 8), ";")
   For j = 0 To UBound(sq)
        For jj = 0 To UBound(sq1)
            arr(n, 0) = sn(i, 1)
            arr(n, 1) = sn(i, 2)
            arr(n, 2) = sn(i, 3)
            arr(n, 3) = sn(i, 4)
            arr(n, 4) = sn(i, 5)
            arr(n, 5) = sn(i, 6)
            arr(n, 6) = sn(i, 7)
            arr(n, 7) = sq1(jj)
            arr(n, 8) = sq(j)
            arr(n, 9) = sn(i, 10)
            arr(n, 10) = sn(i, 11)
            n = n + 1
         Next jj
   Next j
Next i
    With Sheets(2)
     .Cells(1).Resize(UBound(arr), 11) = arr
     .Columns.AutoFit
    End With
End Sub

 

[Lex1972]

Arrie & Harry

Hartelijk dank voor jullie hulp , werkt als een speer nu.

Groet Alex

 

[HSV]

De array wordt misschien iets te groot met 50*, en de code wordt er ook niet sneller op met zoveel gegevens.
Hier een methode voor een zuivere arraygrootte en iets meer snelheid.

Sub hsv()
Dim sn, sq, sq1, i As Long, j As Long, jj As Long
Application.ScreenUpdating = False
sn = Sheets(1).Cells(1).CurrentRegion
ReDim arr(UBound(sn, 2) - 1, 0) As String
For i = 2 To UBound(sn)
    sq = Split(sn(i, 9), ";")
    sq1 = Split(sn(i, 8), ";")
   For j = 0 To UBound(sq)
        For jj = 0 To UBound(sq1)
            arr(0, UBound(arr, 2)) = sn(i, 1)
            arr(1, UBound(arr, 2)) = sn(i, 2)
            arr(2, UBound(arr, 2)) = sn(i, 3)
            arr(3, UBound(arr, 2)) = sn(i, 4)
            arr(4, UBound(arr, 2)) = sn(i, 5)
            arr(5, UBound(arr, 2)) = sn(i, 6)
            arr(6, UBound(arr, 2)) = sn(i, 7)
            arr(7, UBound(arr, 2)) = sq1(jj)
            arr(8, UBound(arr, 2)) = sq(j)
            arr(9, UBound(arr, 2)) = sn(i, 10)
            arr(10, UBound(arr, 2)) = sn(i, 11)
            ReDim Preserve arr(10, UBound(arr, 2) + 1)
         Next jj
     Next j
Next i
    With Sheets(2)
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
     .Columns.AutoFit
    End With
End Sub

 

[VenA]

Hoewel het een extra lusje is zou ik de grootte van arr laten berekenen

sn = Sheets(1).Cells(1).CurrentRegion
For t = 2 To UBound(sn)
    t1 = t1 + (UBound(Split(sn(t, 8), ";")) + 1) * (UBound(Split(sn(t, 9), ";")) + 1)
Next t
ReDim arr(t1, UBound(sn, 2))

 

[HSV]

Extra lusje niet nodig bij #13.