Ingredientenlijst tabel transponeren

[paul71666]

Ik heb uit een ERP ICT systeem een lijst met alle recepten in kolom A en de bijbehorende ingrediënten in kolom B waarin het recept wordt per rij herhaald en erachter het ingrediënt, dus als het recept 5 ingrediënten bevat zijn er 5 rijen.
Ik zou deze graag transponeren in een tabelvorm krijg met in kolom A het recept en in kolom B tm bijv F de ingredienten.
Zie voorbeeld.
Hoe doe ik dat? Wie kan mij helpen?
Ter info
- er kunnen van 3 tm 10 ingrediënten zijn
- de ingrediënten zijn weergegeven als TEKST (ook al zijn het nummers maar soms met een nul ervoor (het zijn artikelnummers)
Hoor graag
Alvast dank,
Paul

En PS: soms komt een ingrediënt meer keer voor in een recept, het zou mooi zijn als hij alleen alle unieke ingrediënten opneemt, maar dat kan ik evt ook zelf doen door in bronbestand eea te ontdubbelen

 

[cow18]

in excel365 vrij gemakkelijk op te lossen, wat is je excel-versie ?
Anders wordt het een macro

 

[AlexCEL]

Kan ook met formules. Zie bijlage.

Let op: het betreft matrixfuncties, d.w.z. afsluiten met Control+Shift+Enter als je geen Excel 365 gebruikt.

Mocht je wel Excel 365 gebruiken zit er ook nog een extra optie in.

 

[emields]

of met vba

 

[cow18]

wist ik wel, maar ik heb een aversie tegen matrixformules, erfelijk belast.

 

[AlexCEL]

:shocked:

 

[paul71666]

Dank allen! Opgelost. Ik heb Office 2013 dus 365 viel af. k heb even lopen stoeien met de matrix functies maar kwam er niet uit hoe je het bereik vergrootte (simpel A19 op twee plekke vervangen door A15000 en dan CTRL SHIFT ENTER gaf foutmelding. Dus de macro, wel even beetje aanpassen aan bereik, en laten stampen en ja wonder is geschiedt. Dank
Groet
Paul

 

[VenA]

Deze staat een stuk minder te stampen.

Sub VenA()
  Const x = 11 'ingredienten +1
  Dim a(x)
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    If d.Exists(ar(j, 1)) Then
      b = d(ar(j, 1))
      If IsError(Application.Match(ar(j, 2), b, 0)) Then
        b(x) = b(x) + 1
        b(b(x)) = ar(j, 2)
        d(ar(j, 1)) = b
      End If
     Else
      a(0) = ar(j, 1)
      a(1) = ar(j, 2)
      a(x) = 1
      d(ar(j, 1)) = a
    End If
  Next j
  Cells(8, 4).Resize(d.Count, x) = Application.Index(d.items, 0)
End Sub

 

[HSV]

Eenvoudiger.

Sub hsv()
Dim sv, a, i As Long
sv = Sheets("Blad1").Cells(1).CurrentRegion
ReDim b(UBound(sv) + 1)
  With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sv)
            a = .Item(sv(i, 1))
             If IsEmpty(a) Then a = b
              If IsError(Application.Match(sv(i, 2), a, 0)) Then
                 a(0) = sv(i, 1)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(i, 2)
                 .Item(sv(i, 1)) = a
              End If
        Next
    Cells(12, 4).Resize(.Count, UBound(a) - 1) = Application.Index(.items, 0)
  End With
End Sub

Volgens het voorbeeld kan het zo.

Sub hsv()
Dim sv, a, i As Long
sv = Sheets("Blad1").Cells(1).CurrentRegion
ReDim b(UBound(sv) + 1)
  With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sv)
            a = .Item(sv(i, 1))
             If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(i, 2)
                 .Item(sv(i, 1)) = a
        Next
    Cells(12, 4).Resize(.Count, UBound(a) - 1) = Application.Index(.items, 0)
  End With
End Sub

 

[paul71666]

Thx!

Nog mooier en sneller!
Dank voor jullie reacties, ik ben geholpen
Paul