Solved: Transpose table of data

[dgilbert]

I have a table of data that needs to be transposed in a particular way. This table could have up to 1500 rows of data very similar to the example shown in the attached Excel file. Could someone help me with a VBA Macro to help accomplish this? It could be a huge time saver for me. Please see the attached file for more information.

Thank you very much.

[Bob Phillips]

[vba]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long, j As Long
Dim LastRow As Long
Dim LastCol As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = LastRow To 3 Step -1

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
.Rows(i + 1).Resize(LastCol - 1).Insert
For j = LastCol To 2 Step -1

.Cells(i, "A").Copy .Cells(i + j - 1, "A")
.Cells(i, j).Copy .Cells(i + j - 1, "B")
Next j

.Rows(i).Delete
Next i

.Rows(1).Delete
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("C1").Resize(, LastCol - 2).ClearContents
.Range("A1").Value = "Payment"
End With

End Sub
[/vba]

[dgilbert]

Thank you. This works very good. I am getting a Run Time Error 1004 but it doens't seem to affect anything. Anything I can do to correct the error?

Thanks again for the quick reply.

[Bob Phillips]

Where does the error occur?

[dgilbert]

When I debug, it stops at this line of code:


.Rows(i + 1).Resize(LastCol - 1).Insert

Thanks again for your help.

[Bob Phillips]

I have just run it again on the workbook that you posted and I get no error, so you need to post the offending workbook.

[dgilbert]

I attached a copy of the spreadsheet with an example table to transpose. The VBA code is included. When I run it I get a run time error # 1004. Otherwise the macro seems to be doing what it is supposed to.

Thanks again for your help.

[Bob Phillips]

I had assumed that those two blank rows at the top were not in the real spreadsheet.

[vba]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long, j As Long
Dim LastRow As Long
Dim LastCol As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = LastRow To 5 Step -1

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
.Rows(i + 1).Resize(LastCol - 1).Insert
For j = LastCol To 2 Step -1

.Cells(i, "A").Copy .Cells(i + j - 1, "A")
.Cells(i, j).Copy .Cells(i + j - 1, "B")
Next j

.Rows(i).Delete
Next i

.Rows(3).Delete
LastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
.Range("C3").Resize(, LastCol - 2).ClearContents
.Range("A3").Value = "Payment"
End With

End Sub
[/vba]

[dgilbert]

Ok. Thanks. That takes care of the problem. You were a big help!