VBA to transpose rows to columns with varying rows (and remove first character)

[CraigG]

Hi

I have an Excel file (exported from a system) which has rows of data. I need the rows transposing to columns. The problem I have is that the set of rows varies so it's not as simple as rows 1-5, then 6-10, 11-15, etc to transposing columns. An example of my data is below:

COLUMN A:
[TABLE="width: 347"]
<tbody>[TR]
[TD]^[/TD]
[/TR]
[TR]
[TD]D5/25/15[/TD]
[/TR]
[TR]
[TD]U600.00[/TD]
[/TR]
[TR]
[TD]T600.00[/TD]
[/TR]
[TR]
[TD]CX[/TD]
[/TR]
[TR]
[TD]PTEST1[/TD]
[/TR]
[TR]
[TD]MMEMO1[/TD]
[/TR]
[TR]
[TD]LCATEGORYA[/TD]
[/TR]
[TR]
[TD]^[/TD]
[/TR]
[TR]
[TD]D3/11/16[/TD]
[/TR]
[TR]
[TD]U-600.00[/TD]
[/TR]
[TR]
[TD]T-600.00[/TD]
[/TR]
[TR]
[TD]NTXFR[/TD]
[/TR]
[TR]
[TD]PTEST1[/TD]
[/TR]
[TR]
[TD]MMEMO1[/TD]
[/TR]
[TR]
[TD]LCATEGORYB[/TD]
[/TR]
[TR]
[TD]^[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 347"]
<tbody>[TR]
[TD]D10/3/17[/TD]
[/TR]
[TR]
[TD]U-169.20[/TD]
[/TR]
[TR]
[TD]T-169.20[/TD]
[/TR]
[TR]
[TD]NTXFR[/TD]
[/TR]
[TR]
[TD]PTEST3[/TD]
[/TR]
[TR]
[TD]LCATEGORYAA[/TD]
[/TR]
[TR]
[TD]SCATEGORYAA[/TD]
[/TR]
[TR]
[TD]EMEMOA1[/TD]
[/TR]
[TR]
[TD]$-56.40[/TD]
[/TR]
[TR]
[TD]SCATEGORYAB[/TD]
[/TR]
[TR]
[TD]EMEMOA2[/TD]
[/TR]
[TR]
[TD]$-56.40[/TD]
[/TR]
[TR]
[TD]SCATEGORYAC[/TD]
[/TR]
[TR]
[TD]EMEMOA3[/TD]
[/TR]
[TR]
[TD]$-56.40[/TD]
[/TR]
[TR]
[TD]^[/TD]
[/TR]
</tbody>[/TABLE]

I want the above transposing to columns by matching the first character of the row and putting it in a column, eg, all rows starting with D go in column A (and remove the first char) - eg, row 2, 'D5/25/15' into column A '5/25/15'. The '^' symbols denotes the start and end of the 'set' of data in the rows. I have 1000s of rows so can't do it manually. The above would look like...


A--------------B------------C--------------D-----------E------------F----------------G----------------H------------I
(prefixed with... in the rows...)
D-------------U-------------T--------------$------------C-----------N----------------P----------------M------------L and S


5/25/15------600.00------600.00----------------------X----------------------------TEST1-----------MEMO1------CATEGORYA


3/11/16------(600.00)----(600.00)---------------------------------TXF-------------TEST1----------MEMO1------CATEGORYB


10/3/17------(169.20)----(169.20)-------------------------------- TXF-------------TEST3------------------------CATEGORYAA
10/3/17-----------------------------------(56.40)-----------------------------------------------------MEMOA1----CATEGORYAA
10/3/17-----------------------------------(56.40)-----------------------------------------------------MEMOA2----CATEGORYAB
10/3/17-----------------------------------(56.40)-----------------------------------------------------MEMOA3----CATEGORYAC



You will see the added complication is the last 'set' of rows where the format is slightly different and requires the date (prefixed with D) copied again for each row.

Can anyone help with any VBA?

Thanks in advance.

Craig

 

[hateme28]

Try this, it should get you started. Be sure to change the name of the sheet in the code

Sub  transpose_rows_columns()    
Dim arr() As Variant
    
    'get last column in first row
    lcol = Cells(1, Columns.Count).End(xlToLeft).Column
    'make array the length of cols
    ReDim arr(lcol)
    
    'get largest row in current column
    For i = 0 To lcol - 1
        lrow = Cells(Rows.Count, i + 1).End(xlUp).Row
        If largestRow < lrow Then
            largestRow = lrow
        End If
    Next
    'make array the size of the table
    ReDim arr(lcol - 1, largestRow - 1)
    'loop through columns
    For i = 1 To lcol
        'get last row in current column
        lrow = Cells(Rows.Count, i).End(xlUp).Row
        'loop through rows
        For j = 1 To lrow
            'assign each row in column to array and remove first value
            arr(i - 1, j - 1) = Mid(Cells(j, i).Value, 2, Len(Cells(j, i).Value))
        Next
    Next
    'clear contents of the sheet
    Sheets("Name_of_sheet").UsedRange.ClearContents
    'transpose values in array
    For i = LBound(arr) To UBound(arr)
        For j = 0 To UBound(arr, 2)
            Cells(i + 1, j + 1) = arr(i, j)
        Next
    Next
    
End Sub