Transpose Every Row From Multiple Sheet Into To One Sheet Into Multiple Column

[Jhon Mustofa]

hi expert..
the following problem, i would hope someone would help me out to solve this problem:
i have a workbook that contains several sheet with random name sheet. For each sheet have the same format but different data.
i want to transpose every 22 or n rows from multiple sheet and multiple column to one sheet into multiple columns. Then my data contains merge cell and i want keep it. The following cell below that i want to transpose 12 cells with criteria like this:
start from transpose cell C3,C4,C5,C7,C8,C11,C12,E9,E11,E12,C15 and C21 (sheet "lap-1)
start from transpose cell C25,C26,C27,C29,C30,C33,C34,E31,E33,E34,C37 and C43 (sheet "lap-1)
etc...
with interval row is 22 row and repeated occurring for the other sheet

how to transpose to other sheet e.g. "sheet "destination" or other sheet name.
for easy i highlighted color cell.
here attachment file

any help, greatly appreciated
john m

[Mumps1]

Before trying the macro below, you will have to unmerge all the cells containing "Nama Bangunan Air" in column A of all the worksheets. You should avoid using merged cells at all cost because they almost always give macros problems. Also start with a blank "destination" sheet.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, fnd As Range, sAddr As String, Col As Long
    Set desWS = Sheets("destination")
    For Each ws In Sheets
        If ws.Name <> "destination" Then
            LastRow = desWS.Range("B" & desWS.Rows.Count).End(xlUp).Row
            Set fnd = ws.Range("A:A").Find("Nama Bangunan Air", LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    With desWS
                        Col = .Cells(LastRow + 1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
                        .Cells(LastRow + 1, Col).End(xlUp).Offset(1).Resize(, 12).Value _
                            = Array(fnd.Offset(, 2), fnd.Offset(2, 2), fnd.Offset(3, 2), fnd.Offset(5, 2), fnd.Offset(6, 2), fnd.Offset(8, 2), fnd.Offset(9, 2) _
                            , fnd.Offset(6, 4), fnd.Offset(8, 4), fnd.Offset(9, 4), fnd.Offset(12, 2), fnd.Offset(18, 2))
                    End With
                    Set fnd = ws.Range("A:A").FindNext(fnd)
                Loop While fnd.Address <> sAddr
                sAddr = ""
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

[Mumps1]

This should work without unmerging the cells.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, ws As Worksheet, fnd As Range, sAddr As String, Col As Long
    Set desWS = Sheets("destination")
    For Each ws In Sheets
        If ws.Name <> "destination" Then
            LastRow = desWS.Range("B" & desWS.Rows.Count).End(xlUp).Row
            Set fnd = ws.Range("A:B").Find("Nama Bangunan Air", LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    With desWS
                        Col = .Cells(LastRow + 1, Columns.Count).End(xlToLeft).Offset(0, 1).Column
                        .Cells(LastRow + 1, Col).End(xlUp).Offset(1).Resize(, 12).Value _
                            = Array(fnd.Offset(, 1), fnd.Offset(2, 1), fnd.Offset(3, 1), fnd.Offset(5, 1), fnd.Offset(6, 1), fnd.Offset(8, 1), fnd.Offset(9, 1) _
                            , fnd.Offset(6, 3), fnd.Offset(8, 3), fnd.Offset(9, 3), fnd.Offset(12, 1), fnd.Offset(18, 1))
                    End With
                    Set fnd = ws.Range("A:B").FindNext(fnd)
                Loop While fnd.Address <> sAddr
                sAddr = ""
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

[Jhon Mustofa]

hi Mumps1....thank yo so much.
Working well!!!!

[Mumps1]

You are very welcome.