Macro omzetten met 2 voorwaarden

[Moche56]

Goedemiddag,

Bijgevoegd bestand bevat een macro die de gegevens uit de eerste tabblad als volg omzet in de tweede:

• 
  Items uit de eerste kolom verticaal herhalen met items uit de tweede, derde, enz.
  Stop na 12 kolommen
  de regel niet kopieer wanneer geen 1 staat in de laatste kolom

Het resultaat is:

• 
  Project 1 : uren week 12
  Project 1 : uren week 13
  ......
  Project 2 : uren week 12
  Project 2 : uren week 13
  .....
  enz.

De wijziging die ik nodig heb (maar niet kundig genoeg voor ben) is het weergegeven van de bovenste rij als extra kolom. Dus als volgt:

• 
  Project 1 : week 12 : uren week 12
  Project 1 : week 13: uren week 13
  Project 1 : week 14: uren week 14
  ......
  Project 2 : week 12 : uren week 12
  Project 2 : week 13: uren week 13
  Project 2 : week 14: uren week 14
  .....
  enz.

Ik ben vaak goed geholpen op deze forum.
Het wordt zeer gewaardeerd.

Groet,
Moché

 

[JEC.]

Bvb;

Sub jec()
 ar = Sheets("Test1").Cells(1, 1).CurrentRegion
 Set sht = Sheets("PLIM1")
 
 With CreateObject("scripting.dictionary")
   For j = 2 To UBound(ar)
      For jj = 2 To UBound(ar, 2) - 1
        If ar(j, jj) <> 0 And ar(j, 12) = 1 Then .Item(.Count) = Array(ar(j, 1), ar(1, jj), ar(j, jj))
      Next
   Next
   sht.Cells(1, 1).CurrentRegion.Offset(1).ClearContents
   sht.Cells(2, 1).Resize(.Count, 3) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[Moche56]

Bedankt JV

Een mooi en strak oplossing.
Bedankt. :thumb:

Het is anders dan wat ik eerst had en dus goed om mee te leren.

Fijne zondag

Grt, Moché

 

[JEC.]

Graag gedaan en van hetzelfde!