Transposing multiple rows into mutliple columns

I have spreadsheet with 4 columns but I need to transpose only 3 columns (without 1st column) with about 2000 rows of data where the data category repeats if in columnA is word "map" (every 4-5 rows down).
I have 52 sheets of data in the same format and at the end all transposed data has to be merged together into one sheet.
Data looks like:
map, CompA, SreviceA,DetailsA1
,AddressA, IncomeA,DetailsA2
,CityA,FeesA, DetailsA3
WebA
map, CompB, SreviceB,DetailsB1
,AddressB, IncomeB,DetailsB2
,CityB,FeesB, DetailsB3
WebB
It should be:
CompA, ServiceA, DetailsA1,AddressA, IncomeA, DetailsA2, CityA, FeesA, DetailsA3, WebA
CompB, ServiceB, DetailsB1,AddressB, IncomeB, DetailsB2, CityB, FeesB, DetailsB3, WebB


Please see the attached file.


Does anyone have a code for this please?

Something like:

Public Sub MoveData(ByVal rngSource As Excel.Range, ByVal rngDest As Excel.Range, _
    Optional ByVal bolRefresh As Boolean = False)

    Dim arrSource               As Variant
    Dim arrDest                 As Variant

    Dim lngLastRow              As Long
    Dim lngCurrRow              As Long
    Dim lngNextRow              As Long
    Dim lngEndRow               As Long
    Dim intCol                  As Integer
    Dim lngRow                  As Integer

    On Error Resume Next
    lngLastRow = rngSource.Parent.Columns(2).Find(What:="*", After:=[B1], _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookAt:=xlPart, LookIn:=xlValues).Row
    If Err <> 0 Then
        lngLastRow = 0
    End If
    On Error GoTo 0
    If lngLastRow > 0 Then
        ReDim arrDest(1 To 15, 1 To 1)
        arrSource = rngSource.Parent.Cells(2, 1).Resize(lngLastRow - 1, 4)
        For lngCurrRow = LBound(arrSource) To UBound(arrSource)
            If arrSource(lngCurrRow, 1) = "Map" Then
                For lngNextRow = lngCurrRow + 1 To UBound(arrSource)
                    If arrSource(lngNextRow, 1) = "Map" Then
                        Exit For
                    End If
                Next lngNextRow
                If lngNextRow > UBound(arrSource) Then
                    lngEndRow = UBound(arrSource)
                Else
                    lngEndRow = lngNextRow - 1
                End If
                If lngEndRow - lngCurrRow > 4 Then
                    MsgBox "Too many rows of data:" & vbCrLf & vbCrLf _
                        & "'" & rngSource.Parent.Name & "'!" & rngSource.Name, vbOKOnly
                Else
                    If arrDest(1, UBound(arrDest, 2)) > "" Then
                        ReDim Preserve arrDest(1 To 15, 1 To UBound(arrDest, 2) + 1)
                    End If
                    For lngRow = lngCurrRow To lngEndRow
                        For intCol = 2 To 4
                            arrDest((lngRow - lngCurrRow) * 3 + intCol - 1, UBound(arrDest, 2)) = arrSource(lngRow, intCol)
                        Next intCol
                    Next lngRow
                End If
                lngCurrRow = lngEndRow
            End If
        Next lngCurrRow

        On Error Resume Next
        lngLastRow = rngDest.Parent.Columns(1).Find(What:="*", After:=[A1], _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
            LookAt:=xlPart, LookIn:=xlValues).Row
        If Err > 0 Then
            Err = 0
            lngLastRow = 1
        End If
        On Error GoTo 0
        If bolRefresh Then
            rngDest.Offset(1, 0).Resize(lngLastRow - 1, 1).EntireRow.Delete
            lngLastRow = 1
        End If
        rngDest.Offset(lngLastRow, 0).Resize(UBound(arrDest, 2), UBound(arrDest)) = Application.Transpose(arrDest)
        
    End If

    Set rngDest = Nothing
    Set rngSource = Nothing

End Sub

called like this:

call movedata(worksheets("SourceData").range("A1"), worksheets("Destination").range("A1"), true)

or

call movedata(worksheets("SourceData").range("A1"), worksheets("Destination").range("A1"))

The true parameter will clear out the data in the destination before pasting new data.

The MoveData procedure takes pointers to the first cell in the source range and destination ranges and a true/false as parameters. It first finds the number of rows in the source data and copies the entire data set to an array. It loops through the array, looking for "Map" in the first column. When it finds "Map", it adds a row to the destination array and moves the data to it. When the destination array is complete, it will conditionally delete existing data at the destination, then copy the destination array.

I don't have it looking for any keywords other than "Map", so if the source data isn't clean this will have to be reworked.

Hi wallyeye

I received the following error message:
Run-time error '1004':
Run method of Application class failed

The maximum number of elements in the array was exceeded.
Please advise.

---------- Post added at 09:00 PM ---------- Previous post was at 08:49 PM ----------

Hi jindon,
Thanks for the code but it dosen’t work, it copies 8 rows.
The number of rows in one category can be different sometimes is 4 sometimes 5.
I think the code should look for “Map” in col A and when it finds the next 4 or 5 rows (whole category) should be copied and transformed.
Any ideas?
Thanks!

Originally Posted by gracek

Hi jindon,
Thanks for the code but it dosen’t work, it copies 8 rows.
The number of rows in one category can be different sometimes is 4 sometimes 5.
I think the code should look for “Map” in col A and when it finds the next 4 or 5 rows (whole category) should be copied and transformed.
Any ideas?
Thanks!

1) Have you tried the file I have attached?
2) If you are talking about the data formatted differently, I need to see the data and the result that you want.

Originally Posted by jindon

1) Have you tried the file I have attached?
2) If you are talking about the data formatted differently, I need to see the data and the result that you want.

Hi jindon,
I have attached the entire file with data. The Destination tab contains the desired output.
I really appreciate your help.

try

Sub test()
    Dim myAreas As Areas, i As Long, n As Long
    Application.ScreenUpdating = False
    With Sheets("sourcedata")
        Set myAreas = .Range("b2", .Range("b" & Rows.Count).End(xlUp)).Offset(, -1).SpecialCells(4).Areas
    End With
    For i = 1 To myAreas.Count
        n = 1
        With myAreas(i)
            For ii = 1 To 3
                .Offset(-1, ii).Resize(.Rows.Count + 1).Copy
                Sheets("destination").Cells(i, n).PasteSpecial Transpose:=True
                n = n + 5
            Next
        End With
    Next
    Sheets("destination").Columns("j").Delete
    With Application
        .ScreenUpdating = True
        .CutCopyMode = False
    End With
    Set myAreas = Nothing
End Sub