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

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

<tbody>
</tbody>

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;">

905

<tbody>
</tbody>

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]

A	B	C	D	E	F	G	H	I	J	K	L	M	N
905	101	4100	UC000	526	LU1						52	52	Jan
905	101	4100	UC000	526	LU1						58	58	Feb
905	101	4100	UC000	526	LU1						53	53	Mar

<tbody>
</tbody>

 

[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.