Loop through sheet 1 and copy/paste transpose every 12 rows

[hakeem26]

Good Day to all,
I am new to VBA, I have Budget data in sheet1 as follow

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[TD]O[/TD]
[TD]P[/TD]
[TD]Q[/TD]
[TD]R[/TD]
[TD]S[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Comp[/TD]
[TD]Div[/TD]
[TD]Acct[/TD]
[TD]CC[/TD]
[TD]PG[/TD]
[TD]Dim[/TD]
[TD]CURR[/TD]
[TD]Jan[/TD]
[TD]Feb[/TD]
[TD]Mar[/TD]
[TD]Apr[/TD]
[TD]May[/TD]
[TD]Jun[/TD]
[TD]Jul[/TD]
[TD]Aug[/TD]
[TD]Sep[/TD]
[TD]Oct[/TD]
[TD]Nov[/TD]
[TD]Dec[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]905[/TD]
[TD]101[/TD]
[TD]4100[/TD]
[TD]UC000[/TD]
[TD]526[/TD]
[TD]LU1[/TD]
[TD]USD[/TD]
[TD]52[/TD]
[TD]58[/TD]
[TD]53[/TD]
[TD]63[/TD]
[TD]57[/TD]
[TD]56[/TD]
[TD]53[/TD]
[TD]59[/TD]
[TD]57[/TD]
[TD]63[/TD]
[TD]69[/TD]
[TD]72[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]905[/TD]
[TD]102[/TD]
[TD]4215[/TD]
[TD]UC526[/TD]
[TD]313[/TD]
[TD]LO1[/TD]
[TD]USD[/TD]
[TD]14[/TD]
[TD]17[/TD]
[TD]16[/TD]
[TD]19[/TD]
[TD]12[/TD]
[TD]23[/TD]
[TD]17[/TD]
[TD]16[/TD]
[TD]15[/TD]
[TD]12[/TD]
[TD]19[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I want to copy this into sheet 2 using loop because sheet 1 is so long, I record the following code.
****** id="cke_pastebin" style="position: absolute; top: 89.6px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">[TABLE="width: 500"]
<tbody>[TR]
[TD]905[/TD]
[/TR]
</tbody>[/TABLE]

Sub Macro8()
'
' Macro8 Macro
'


'
    Sheets("B").Select
    Range("H2:S2").Copy
    Sheets ("BM3"), Range("L1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    Selection.Copy
    Range("M1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("B").Select
    Range("H1:S1").Select
    Selection.Copy
    Sheets("BM3").Select
    Range("N1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("B").Select
    Range("A2:F2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BM3").Select
    Range("A1:A12").Select
    ActiveSheet.Paste
    ''''''''''''''''''''''''''''''''''
    Sheets("B").Select
    Range("H3:S3").Select
    Selection.Copy
    Sheets("BM3").Select
    Range("L13").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    Selection.Copy
    Range("M13").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("B").Select
    Range("$H$1:$S$1").Select
    Selection.Copy
    Sheets("BM3").Select
    Range("N13").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Sheets("B").Select
    Range("A3:F3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BM3").Select
    Range("A13:A24").Select
    ActiveSheet.Paste
    ''''''''''''''''''''''''''''''''''
    Sheets("B").Select
    Range("H4:S4").Select
    Selection.Copy
    Sheets("BM3").Select
    Range("L25").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    Selection.Copy
    Range("M25").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("B").Select
    Range("$H$1:$S$1").Select
    Selection.Copy
    Sheets("BM3").Select
    Range("N25").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Sheets("B").Select
    Range("A4:F4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BM3").Select
    Range("A25:A36").Select
    ActiveSheet.Paste
    ''''''''''''''''''''''''''''''''''
End Sub

Help please

 

[PCL]

Can you show how is the final result is sheet2 ?

 

[Fluff]

@hakeem26
You need to use the reply button, not the report button.

 

[hakeem26]

[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]905[/TD]
[TD]101[/TD]
[TD]4100[/TD]
[TD]UC000[/TD]
[TD]526[/TD]
[TD]LU1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]52[/TD]
[TD]52[/TD]
[TD]Jan[/TD]
[/TR]
[TR]
[TD]905[/TD]
[TD]101[/TD]
[TD]4100[/TD]
[TD]UC000[/TD]
[TD]526[/TD]
[TD]LU1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]58[/TD]
[TD]58[/TD]
[TD]Feb[/TD]
[/TR]
[TR]
[TD]905[/TD]
[TD]101[/TD]
[TD]4100[/TD]
[TD]UC000[/TD]
[TD]526[/TD]
[TD]LU1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]53[/TD]
[TD]53[/TD]
[TD]Mar[/TD]
[/TR]
</tbody>[/TABLE]

 

[PCL]

The currency "USD" don't appear anymore ???

because sheet 1 is so long

you mean too large, because the new sheet will have a lot of more rows !!!
In new sheet , column L and M are identical ???

 

[PCL]

Perhaps next code ...!

Option Explicit


Sub Treat()
Const Ws1N = "Sheet1"
Const Ws2N = "Sheet2"
Const Sepa = "/"
Dim WS1 As Worksheet, WS2 As Worksheet
Dim I  As Integer, II As Integer, J As Integer


    Set WS1 = Sheets(Ws1N): Set WS2 = Sheets(Ws2N)
    Application.ScreenUpdating = False
    With WS2
        .Cells.ClearContents
        .Cells(1, 1).Resize(1, 14) = Array("Comp", "Div", "Acct", "CC", "PG", _
               "Dim", "", "", "", "", "", "--", "--", "Month")
    End With
    II = 1
    With WS1
        For I = 2 To .Cells(Rows.Count, 1).End(3).Row
            For J = 8 To 19
                II = II + 1
                Range(.Cells(I, 1), .Cells(I, 6)).Copy WS2.Cells(II, 1)
                WS2.Cells(II, 12) = WS1.Cells(I, J)
                WS2.Cells(II, 13) = WS1.Cells(I, J)
                WS2.Cells(II, 14) = WS1.Cells(1, J)
            Next J
        Next I
    End With
    Application.ScreenUpdating = True
End Sub

 

[hakeem26]

Thank you so much, work perfect.