script transponeren

[moensk]

ik heb een tabel van 33 kolommen en 180 rijen waar ik transponeren moet op toepassen + copieren cellen
hij moet daar steeds nieuwe tabellen van maken
in bijlage een kort voorbeeld, kan dit via een script ...

 

[Ginger]

Moensk, ik heb een - naar mijn gevoel - geslaagde poging gedaan om je gevraagde tabellen te genereren. Ik weet niet of ik m'n code heel fraai vind omdat er behoorlijk wordt "gelust" en daarmee ook de array voor de output om de haverklap vergroot. Maar goed, hij doet het wel!
Lijntjes zetten doe ik niet, dat mag je dan zelf naderhand nog doen.

 

[moensk]

Ginger, super bedankt, ik ga hem bestuderen

 

[snb]

@Ginger

Of zo ?

Sub M_snb()
    With Sheet2.Cells(1).CurrentRegion
        sn = .Resize(.Rows.Count + 1)
    End With
    
    c00 = Replace("0 1 2 2 2 2 2 0 0 ", "0", UBound(sn))
    
    For j = 2 To UBound(sn) - 1
       c01 = c01 & Replace(c00, "2", j)
    Next
    
    sp = Application.Index(sn, Application.Transpose(Split(Trim(c01))), Array(1, 2, 3, 4, 5, 6))
    
    For j = 1 To UBound(sp)
       If sp(j, 1) = "code" Then
          sp(j - 1, 1) = sp(j + 1, 1)
          sp(j, 1) = "plts"
          For jj = 2 To UBound(sp, 2)
             sp(j + jj - 1, 1) = sp(j, jj)
             sp(j + jj - 1, 2) = sp(j + 1, jj)
          Next
        End If
    Next
    
    Sheet2.Cells(1, 10).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

 

[snb]

@cow

Dat zie ik niet zo snel.
Ik zou altijd met een Array werken; dus dan zijn daarmee meteen beide dimensies bekend.

Ik had nog wel deze (als illustratie van het gebruik van een Dictionary)

Sub M_snb()
    sn = Sheet2.Cells(1).CurrentRegion
    sp = Sheet2.Cells(1).CurrentRegion.Rows(1)
    sq = Sheet2.Cells(1).CurrentRegion.Offset(UBound(sn)).Rows(1)
    sp(1, 1) = "plts"
    
    With CreateObject("scripting.dictionary")
       For j = 2 To UBound(sn)
          For jj = 0 To UBound(sp, 2) + 1
            st = sq
            If jj = 0 Then
                st(1, 1) = sn(j, 1)
                .Item(.Count) = st
                .Item(.Count) = sp
            ElseIf jj < UBound(sp, 2) Then
                st(1, 1) = jj
                st(1, 2) = sn(j, jj + 1)
                .Item(.Count) = st
            Else
                .Item(.Count) = sq
            End If
          Next
      Next
      
      Sheet2.Cells(1, 14).Resize(.Count, UBound(sp, 2)) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[Ginger]

@Ginger

Of zo ?

Ik gok dat @Cow zijn reactie heeft verwijderd en daar al had aangegeven dat de TS niet 5 maar 33 kolommen heeft? Dat gaat je eerste getoonde procedure niet doen vrees ik. Hoe dan ook, wel weer mooi gemaakt SNB. Die tweede procedure met de Dict ga ik nog 'ns rustig bestuderen en vooral uitvoeren. Al lezend kan ik 'm in elk geval niet lekker volgen.