Transpose multiple rows at once

[Mah2017]

Hi.
Twice a year i have a task that i hope can be simplified. I'll just show the input and show how it should look at the end


My working budget file has about 40 tabs (each tab represents a different Cost Center).
Each tab if formatted exactly the same way (fig 1)
Each cost center has 117 accounts
My goal is to highlight data in Fig 1 ie (A9:O126)


Fig 1
[TABLE="width: 300"]
<tbody>[TR]
[TD]Account[/TD]
[TD]Description[/TD]
[TD]Cost-Center[/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]4005[/TD]
[TD]Labour[/TD]
[TD]423[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]Services[/TD]
[TD]423[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4280[/TD]
[TD]Rent[/TD]
[TD]423[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[TD]500[/TD]
[/TR]
[TR]
[TD]4320[/TD]
[TD]Material[/TD]
[TD]423[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[TD]200[/TD]
[/TR]
</tbody>[/TABLE]

I need to transpose data for each tab to Fig 2

Fig 2

[TABLE="width: 500"]
<tbody>[TR]
[TD]Account[/TD]
[TD]Cost-Center[/TD]
[TD]Period[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]1[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]2[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]3[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]4[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]5[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]6[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]7[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]8[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]9[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]10[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]11[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4005[/TD]
[TD]423[/TD]
[TD]12[/TD]
[TD]10000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]1[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]2[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]3[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]4[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]5[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]6[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]7[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]8[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]9[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]10[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]11[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]4130[/TD]
[TD]423[/TD]
[TD]12[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]etc[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[mumps]

Do you want to do this for all 40 sheets? Where do you want figure 2 for each sheet to appear?

 

[DanteAmor]

Transpose data for each tab. All tabs in a new sheet or transpose data from each tab in the same tab.

 

[Mah2017]

thanks for reply

Yes the goal would be to do all 40 sheets

In the end Figure 2 needs to be on one new sheet.

 

[mumps]

Create a sheet and name it "Summary". Try this amcro:

Sub transposeRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet, account As Range, desWS As Worksheet
    Set desWS = Sheets("Summary")
    For Each ws In Sheets
        If ws.Name <> "Summary" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For Each account In ws.Range("A2:A" & LastRow)
                With desWS
                    .Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(12, 1) = account
                    .Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(12, 1) = account.Offset(0, 2)
                End With
                With desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0)
                    .Value = 1
                    .AutoFill Destination:=desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Resize(12, 1), Type:=xlFillSeries
                End With
                account.Offset(0, 3).Resize(1, 12).Copy
                desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            Next account
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Create a sheet called "Center"

Try this:

Sub Transponer_Costos()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim n As Double, i As Double, u2 As Double
    '
    Set ws1 = Sheets("Center")
    ws1.Rows("2:" & Rows.Count).ClearContents
    n = 2
    For Each ws2 In Sheets
        Select Case ws2.Name
            'Name of sheets excluded
            Case ws1.Name, "sheet1", "Sheet5"
            
            Case Else
                u2 = ws2.Range("D" & Rows.Count).End(xlUp).Row
                For i = 9 To u2
                    ws1.Range("A" & n).Resize(12).Value = ws2.Cells(i, "A").Value
                    ws1.Range("B" & n).Resize(12).Value = ws2.Cells(i, "C").Value
                    ws1.Range("C" & n).Resize(12).Value = WorksheetFunction.Transpose(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12))
                    ws1.Range("D" & n).Resize(12).Value = WorksheetFunction.Transpose(ws2.Range("D" & i & ":O" & i).Value)
                    n = n + 12
                Next
        End Select
    Next
    MsgBox "End"
End Sub