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

Account	Description	Cost-Center	Jan	Feb	Mar	Apr	May	Jun	Jul	Aug	Sep	Oct	Nov	Dec
4005	Labour	423	10000	10000	10000	10000	10000	10000	10000	10000	10000	10000	10000	10000
4130	Services	423	1000	1000	1000	1000	1000	1000	1000	1000	1000	1000	1000	1000
4280	Rent	423	500	500	500	500	500	500	500	500	500	500	500	500
4320	Material	423	200	200	200	200	200	200	200	200	200	200	200	200

<tbody>
</tbody>

I need to transpose data for each tab to Fig 2

Fig 2

Account	Cost-Center	Period	Amount
4005	423	1	10000
4005	423	2	10000
4005	423	3	10000
4005	423	4	10000
4005	423	5	10000
4005	423	6	10000
4005	423	7	10000
4005	423	8	10000
4005	423	9	10000
4005	423	10	10000
4005	423	11	10000
4005	423	12	10000
4130	423	1	1000
4130	423	2	1000
4130	423	3	1000
4130	423	4	1000
4130	423	5	1000
4130	423	6	1000
4130	423	7	1000
4130	423	8	1000
4130	423	9	1000
4130	423	10	1000
4130	423	11	1000
4130	423	12	1000
etc

<tbody>
</tbody>

 

[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