regels kopieren naar nieuw tabblad

[rthoonsen]

beste,

Ik probeer het volgende voor elkaar te krijgen maar weet niet of dit mogelijk is.
Ik heb een regel met in 1 cel een tekst en in 1 cel D-nummer of D-nummers gescheiden door een comma.
Nou wil ik deze kopieren naar een nieuw tabblad waarbij elke regel gekopieerd wordt maar wel gescheiden door de comma.

onderstaand een voorbeeld en ook zie bijlage:

testvoorbeeld 1 D-02509,D-03022,D-03032,D-03042,D-03929,D-03948,D-03951
testvoorbeeld 2 D-02509
testvoorbeeld 3 D-02509,D-03022
testvoorbeeld 4 D-03929,D-03948,D-03951
testvoorbeeld 5 D-03951

nieuw tabblad
tekst Objecten
testvoorbeeld 1 D-02509
testvoorbeeld 1 D-03022
testvoorbeeld 1 D-03032
testvoorbeeld 1 D-03042
testvoorbeeld 1 D-03929
testvoorbeeld 1 D-03948
testvoorbeeld 1 D-03951
testvoorbeeld 2 D-02509
testvoorbeeld 3 D-02509
testvoorbeeld 3 D-03022
testvoorbeeld 4 D-03929
testvoorbeeld 4 D-03948
testvoorbeeld 4 D-03951
testvoorbeeld 5 D-03951

 

[VenA]

Dat kan vrij eenvoudig met Power Query. Anders wordt het een macro denk ik.

 

[rthoonsen]

Ik ben eigenlijk opzoek naar een macro om dit te doen?
hoe maak ik deze macro?

 

[VenA]

Bv.

Sub VenA()
  ar = Sheets("sheet1").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 1 To UBound(ar)
    x = Split(ar(j, 2), ",")
    For jj = 0 To UBound(x)
      d(d.Count) = Array(ar(j, 1), x(jj))
    Next jj
  Next j
  Sheets("Sheet2").Cells(1, 8).Resize(d.Count, 2) = Application.Index(d.items, 0, 0)
End Sub

 

[rthoonsen]

ah Super alleen als ik het nu toepas in mijn excel met meerdere kolommen dan werkt het wel maar krijg alleen 2 kolommen mee?

Ik probeer eigenlijk net zoals op sheet1 de gehele rij te kopieren echter krijg ik alleen maar 2 kolommen tot mijn beschikking.
Wanneer ik probeer dit aan te passen krijg ik overall #NA# te zien ?

 

[JEC.]

Probeer deze eens

Sub JVVenA()
  ar = Sheets("Sheet1").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  
  For j = 1 To UBound(ar)
    x = Split(ar(j, 50), ",")
      For jj = 0 To UBound(x)
         d(d.Count) = Array(x(jj), Join(Application.Transpose(Application.Transpose(Sheets("Sheet1").Range("A" & j & ":AW" & j))), "~"))
      Next jj
  Next j
   
  With Sheets("Sheet2").Cells(1, 1)
    .Resize(d.Count, 2) = Application.Index(d.items, 0, 0)
    .Offset(, 1).Resize(d.Count).TextToColumns .Offset(, 1), 1, , , , , , , 1, "~"
  End With
End Sub

 

[rthoonsen]

Dank je wel JVeer, het werkt dank je wel ik dacht eerst dat er een beperking op zat maar nee het klopt.

 

[JEC.]

Lastig te zeggen. Plaats het bestand eens waarin het misgaat

 

[rthoonsen]

Ik had niet goed gekeken sorry nee het werkt super dank je wel