VBA Macro to transpose rows to columns based on a keyword

Question

I have data in column A with 65000 rows of data. I need to transpose every x rows of data to x columns after every row that contains the text "< Amt >" without the spaces. For example, data from A1:A9 must be transposed to B1:J1 because row A9 contains the keyword. Yet data from A10:A19 must be transposed to B2:K2 because the keyword appears at the tenth row. I appreciate if anyone can provide VBA code for this.

I'm not sure if it's relevant but each row does contain its own XML identifier. EG, A1 starts and ends with <AccountName>.

ACT Org
16 Ot Rd
Winsted
CT
06028
NONE
501(C)(3)
UNRESTRICTED
2000
ADV Institute
1010 Railroad Ave
Ste 31
Bellingham
WA
98225
NONE
501(C)(3)
UNRESTRICTED
1500

To this

ACT Org	16 Ot Rd	Winsted	CT	6028	NONE	501(C)(3)	UNRESTRICTED	2000
ADV Institute	1010 Railroad Ave	Ste 31	Bellingham	WA	98225	NONE	501(C)(3)	UNRESTRICTED	1500

Before After

Sub TransposeData()
    Dim i As Long, j As Long, k As Long
    Dim lastRow As Long
    Dim rowData As Variant
    
    'Set the number of rows to transpose to X
    Dim X As Integer
    X = 8 'Change this number to the desired value
    
    'Find the last row of data in column A
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    'Loop through each row of data
    For i = 1 To lastRow Step X
        
        'Check if the row contains the keyword
        If InStr(1, Cells(i, 1).Value, "<net>") > 0 Then
            
            'Transpose the rows above the keyword row into columns
            rowData = Range(Cells(i - X + 1, 1), Cells(i - 1, 1)).Value
            For j = 1 To X
                For k = 1 To UBound(rowData, 2)
                    Cells(i - X, k + j - 1).Value = rowData(j, k)
                Next k
            Next j
            
        Else
        
            'Transpose the rows into columns starting from column B
            rowData = Range(Cells(i, 1), Cells(i + X - 1, 1)).Value
            For j = 1 To X
                For k = 1 To UBound(rowData, 2)
                    Cells(i - 1, k + j).Value = rowData(j, k)
                Next k
            Next j
            
        End If
        
    Next i
    
    'Delete the original data in column A
    Range("A1:A" & lastRow).Delete shift:=xlToLeft
    
End Sub

Answer 1

I suggest a different approach using Power Query, available in Excel 2010+ and Microsoft 365.

This is based on the fact that your data has each item surrounded by a pair of tags.

• Read in the table
• Split the tag from the value
• Group each set of data, using <amt> as the tag for the last item
• Pivot each set

With this you will wind up with a Table that has the information organized by tag

To use Power Query

• Assuming your data is in a contiguous range:
• Select some cell in your Data Table
• Data => Get&Transform => from Table/Range or from within sheet
• When the PQ Editor opens: Home => Advanced Editor
• Make note of the Table Name in Line 2
• Paste the M Code below in place of what you see
• Change the Table name in line 2 back to what was generated originally.
• Read the comments and explore the Applied Steps to understand the algorithm

If this document were a valid XML document, there are other methods that could be used, but as presented, it is not

M Code

let

//Change next line to reflect actual data source
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    #"Changed Type1" = Table.TransformColumnTypes(Source,{{"Column1", type text}}),

//Split type and value
    Split = Table.SplitColumn(#"Changed Type1", "Column1", Splitter.SplitTextByAnyDelimiter({">","<"}),3),
    #"Removed Columns" = Table.RemoveColumns(Split,{"Column1.1"}),

//List of all column headers after pivoting
    ColHeaders = List.Distinct(#"Removed Columns"[Column1.2]),

//Create "Grouping" Column
    #"Added Index" = Table.AddIndexColumn(#"Removed Columns", "Index", 0, 1, Int64.Type),
    #"Added Custom" = Table.AddColumn(#"Added Index", "Grouper", each if [Column1.2] = "Amt" then [Index] else null, Int64.Type),
    #"Filled Up" = Table.FillUp(#"Added Custom",{"Grouper"}),
    #"Removed Columns1" = Table.RemoveColumns(#"Filled Up",{"Index"}),

//Group by Grouper column
// Then Pivot each subtable
    #"Grouped Rows" = Table.Group(#"Removed Columns1", {"Grouper"}, {
        {"Pivot", each Table.Pivot(_, ColHeaders,"Column1.2", "Column1.3")}}),
    #"Removed Columns2" = Table.RemoveColumns(#"Grouped Rows",{"Grouper"}),

//Expand the pivoted subtables and set the data types
    #"Expanded Pivot" = Table.ExpandTableColumn(#"Removed Columns2", "Pivot", 
        {"BusinessNameLine1Txt", "AddressLine1Txt", "AddressLine2Txt", "CityNm", "StateAbbreviationCd", "ZIPCd", "RecipientRelationshipTxt", "RecipientFoundationStatusTxt", "GrantOrContributionPurposeTxt", "Amt"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Expanded Pivot",{{"BusinessNameLine1Txt", type text}, {"AddressLine1Txt", type text}, {"AddressLine2Txt", type text}, {"CityNm", type text}, {"StateAbbreviationCd", type text}, {"ZIPCd", type text}, {"RecipientRelationshipTxt", type text}, {"RecipientFoundationStatusTxt", type text}, {"GrantOrContributionPurposeTxt", type text}, {"Amt", Currency.Type}})
in
    #"Changed Type"

Your Data

Results

Answer 2

Transpose Data in Place

Main

Option Explicit

Sub TransposeDataInPlace()
    
    Const HEADER_COLUMNS As Long = 9
    Const DATA_COLUMNS As Long = 10
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = rg.Rows.Count
    
    Dim sData(): sData = rg.Value
    
    Dim drCount As Long
    drCount = Int((srCount - HEADER_COLUMNS) / DATA_COLUMNS) + 1
    If (srCount - HEADER_COLUMNS) Mod DATA_COLUMNS > 0 Then
        drCount = drCount + 1
    End If
    
    Dim dData(): ReDim dData(1 To drCount, 1 To DATA_COLUMNS)
    
    Dim sr As Long
    
    ' Headers
    For sr = 1 To HEADER_COLUMNS
        dData(1, sr) = ParseBetween(CStr(sData(sr, 1)))
    Next sr
    
    Dim c As Long: c = 1
    Dim dr As Long: dr = 2
    
    ' Data
    For sr = HEADER_COLUMNS + 1 To srCount
        dData(dr, c) = ParseBetween(CStr(sData(sr, 1)))
        If c = 10 Then
            c = 1
            dr = dr + 1
        Else
            c = c + 1
        End If
    Next sr
    
    rg.Clear
    
    rg.Resize(drCount, DATA_COLUMNS).Value = dData
    
    MsgBox "Data transposed in place.", vbInformation
    
End Sub

The Help

Function ParseBetween( _
    ByVal GetString As String, _
    Optional ByVal FirstDelimiter As String = ">", _
    Optional ByVal SecondDelimiter As String = "<") _
As String
    
    Dim Pos As Long, Result As String
    
    If Len(GetString) > 0 Then
        Pos = InStr(GetString, FirstDelimiter)
        If Pos > 0 Then
            Result = Right(GetString, Len(GetString) - Pos - Len(FirstDelimiter) + 1)
            If Len(Result) > 0 Then
                Pos = InStr(Result, SecondDelimiter)
                If Pos > 0 Then
                    ParseBetween = Left(Result, Pos - 1)
                End If
            End If
        End If
    End If
                
End Function