Excel probleem

[Jagerjarno]

Het gaat er om dat er een x getal in kolom A staat en in kolom B staat een kenmerk.

Bijvoorbeeld in kolom A1, A2 en A3 staat 14567. met daarnaast in kolom B1 muts,
In kolom B2 zwart en in kolom B3 rond.

Uiteindelijk wil ik alle kenmerken uit kolom B verticaal naast elkaar met daarvoor het nummer wat in Kolom A staat.

Daarnaast wil ik dit doen voor een lijst met ongeveer 1000 rijen.

Eigenlijk moet het getal uit kolom A worden herkent om het op de juiste plek te zetten. Het verschilt namelijk hoeveel kenmerken er zijn.

 

[Cobbe]

=aantal.als(items_in_A;item)*(items_in_B/Overige_items);"")

Ofwel een voorbeeldje posten, dit is hier geen fotoclub, hé.

 

[Jagerjarno]

Bekijk bijlage voorbeeld excel probleem.xlsx

Dankjewel voor je snelle reactie.
Sorry ik ben hier nieuw. Hierbij heb ik een voorbeeld document toegevoegd.

Gegevens 1 is hoe het nu staat. Gegevens 2 is hoe ik het wil hebben.

 

[Cobbe]

Zoiets zou het moeten worden.
In kolom G staat een formule die de unieke nummers uit kolom A haalt.
En via de button worden de bijhorende gegevens nagevuld.

 

[Jagerjarno]

Super het werkt. allereerst super bedankt. Hoe kan ik er nu voor zorgen dat ik de hele lijst in 1 keer omzet?

 

[Cobbe]

Zo goed?

 

[Jagerjarno]

Zodra ik meer als 30 velden er in gooi geeft hij een fout melding. Kan ik dit ergens aanpassen?

 

[Cobbe]

Wijzig deze regel in de code:

.Range("B2:B500").SpecialCells(xlCellTypeVisible).Copy

 

[Ginger]

Nog een optie om er een echte tabel van te maken met Headers en de gegevens netjes daaronder verdeeld...
Ongetwijfeld kon dit mooier met een Dictionary, maar daar blijf ik maar tegenaan hikken. Dus dan maar met lussen...

Sub KolomTabel()

    q1 = Sheets(1).Cells(1).CurrentRegion
    
    i = -1
    For Each el In Application.Index(q1, 0, 1)
        If OudEl <> el Then i = i + 1
        OudEl = el
    Next el
    
    ReDim q2(0 To i, 0 To 1)
    
    For i = 2 To UBound(q1, 1)
        If q1(i, 1) <> q1(i - 1, 1) Then
            ii = ii + 1
            q2(ii, 1) = q1(i, 1)
        End If
        If InStr(1, Join(Application.Index(q2, 1, 0), "|"), Split(Replace(q1(i, 2), " ", ""), ":")(0)) = 0 Then
            ReDim Preserve q2(0 To UBound(q2, 1), 0 To UBound(q2, 2) + 1)
            q2(0, UBound(q2, 2)) = Split(Replace(q1(i, 2), " ", ""), ":")(0)
        End If
        x = Application.Match(Split(Replace(q1(i, 2), " ", ""), ":")(0), Application.Index(q2, 1, 0), 0) - 1
        q2(ii, x) = Split(Replace(q1(i, 2), " ", ""), ":")(1)
    Next i
    
    Range("G1").Resize(UBound(q2, 1) + 1, UBound(q2, 2) + 1) = q2
    
End Sub

Laat je basistabel netjes beginnen in cel A1. Dan zal de nieuwe tabel worden weggeschreven vanaf cel H1

 

[HSV]

Dag Leo,

Persoonlijk vind ik het een mooie code hoor, maar alles moet wel al gesorteerd staan natuurlijk.

Opmerking:
Je array start een kolom te laat; H1 i.pv. G1.
Daarom kom je aan het eind eentje tekort resize(ubound(q2,2) +1).

Sub KolomTabel()


    q1 = Sheets(1).Cells(1).CurrentRegion
    
    'i = -1
    For Each el In Application.Index(q1, 0, 1)
        If OudEl <> el Then i = i + 1
        OudEl = el
    Next el
    
    ReDim q2(0 To i, 0 To 1)
    
    For i = 2 To UBound(q1, 1)
        If q1(i, 1) <> q1(i - 1, 1) Then
            ii = ii + 1
            q2(ii, 0) = q1(i, 1)
        End If
        If InStr(1, Join(Application.Index(q2, 1, 0), "|"), Split(Replace(q1(i, 2), " ", ""), ":")(0)) = 0 Then
            
            q2(0, UBound(q2, 2)) = Split(Replace(q1(i, 2), " ", ""), ":")(0)
            ReDim Preserve q2(0 To UBound(q2, 1), 0 To UBound(q2, 2) + 1)
        End If
        x = Application.Match(Split(Replace(q1(i, 2), " ", ""), ":")(0), Application.Index(q2, 1, 0), 0) - 1
        q2(ii, x) = Split(Replace(q1(i, 2), " ", ""), ":")(1)
    Next i
    
    Range("G1").Resize(UBound(q2, 1), UBound(q2, 2)) = q2
End Sub

 

[Ginger]

Harry, Dank voor je compliment. En zéker dank voor je uitstekende tip dat de gegevens gesorteerd moeten staan!!! @Jagerjarno, hou daar dus wél rekening mee.

Het "te kort komen van 1 element" kan ik niet reproduceren. Zie ook mijn bijlage. Waar zie jij het fout lopen?

[EDIT] Ooooo..... wacht ff... Jij doelt hiermee op mijn "+1" in het resize gedeelte. Nee, dit is expres. Hierdoor kan ik op positie nul van de array óf de kolomheaders plaatsen óf de artikelnummers. (tenminste... zo dacht ik er vanmiddag over toen ik de boel in elkaar draaide... :d)

 

[HSV]

Hoi Leo,

Je redim preserve staat te vroeg in de code.

Range("G1").Resize(UBound(q2, 1) + 1, UBound(q2, 2) + 1) = q2

Hiermee schrijf je de array weg beginnend in G1 tot ???
Op het blad staan ze pas vanaf H1.

Test de aangepaste code daar eens op.

 

[Ginger]

Ahhhh..... Je hebt helemaal gelijk. Qua gegevens mistte ik niets, maar er zat inderdaad een onnodige verhoging in. Top! Tnx.