Sheet bewerken naar nieuwe met macro

[vrouw]

Is het mogelijk om met een macro het volgende voor elkaar te krijgen?

Ik heb het met transpose geprobeerd maar het wil me niet lukken.

Ik heb een (standaard) sheet zie voorbeeld tabblad 1.
Het nadeel daarvan is namelijk dat er van artikelen iets besteld moet worden maar per artikel staat het op één regel voor 3 datums.

Ik zou graag een macro willen hebben die dit bewerkt en dat het er zo uitziet als op sheet 2.
Dus omdat het altijd op 3 datums besteld moet worden zie ik graag 3 regels onder elkaar voor hetzelfde artikel op 3 regels met de datum er naast.

Is dat mogelijk?

 

[VenA]

Probeer het zo eens.

Sub VenA()
ar = Sheets("Invoer").Cells(1).CurrentRegion
ReDim ar1(2, 0)
  For j = 2 To UBound(ar)
    For jj = 7 To UBound(ar, 2)
      ar1(0, UBound(ar1, 2)) = ar(j, 2)
      ar1(1, UBound(ar1, 2)) = Format(ar(1, jj), "m-d-yyyy")
      ar1(2, UBound(ar1, 2)) = ar(j, jj)
      ReDim Preserve ar1(2, UBound(ar1, 2) + 1)
    Next jj
  Next j
  Sheets("Bewerkt").Cells(2, 2).Resize(UBound(ar1, 2), 3) = Application.Transpose(ar1)
End Sub

 

[JeanPaul28]

Kijk eens naar deze oplossing

 

[vrouw]

:thumb: Top dat ziet er goed uit.

Ik ga ermee aan de slag en kijken of ik dat zo kan verwerken.

 

[vrouw]

Oeps, ik ben een kolom vergeten die er ook nog in had gemoeten.(ik gebruik nu de code van VenA)

Ik heb geprobeerd de code te doorgronden maar helaas lukt me dat niet.


Ik zou nog graag de data uit kolom E (tabblad Invoeren) in kolom F (tabblad Bewerkt) willen hebben.

Is dat nog mogelijk?

 

[VenA]

Waarom niet in kolom E (blad Bewerkt)?

Sub VenA()
ar = Sheets("Invoer").Cells(1).CurrentRegion
ReDim ar1(4, 0)
  For j = 2 To UBound(ar)
    For jj = 7 To UBound(ar, 2)
      ar1(0, UBound(ar1, 2)) = ar(j, 2)
      ar1(1, UBound(ar1, 2)) = Format(ar(1, jj), "m-d-yyyy")
      ar1(2, UBound(ar1, 2)) = ar(j, jj)
      ar1(4, UBound(ar1, 2)) = ar(j, 5)
      ReDim Preserve ar1(4, UBound(ar1, 2) + 1)
    Next jj
  Next j
  Sheets("Bewerkt").Cells(2, 2).Resize(UBound(ar1, 2), 5) = Application.Transpose(ar1)
End Sub

 

[vrouw]

Bedankt, ben er weer lekker mee geholpen.

Kolom E is nog om een opmerking te plaatsen.(later in de macro)