VBA Macro Transpose/Delete Rows and continue down spreadsheet with differing total number of rows

[jazzhayward]

Hi All,

I have a little bit of VBA knowledge but am struggling with this one.

I have a data extraction from an accounting system. The first half of the data is represented horizontally as expected, but the second half of the data is somehow expressed vertically (a can of worms I don't need to go into right now).

I need a way to transpose this vertical data to the corresponding row, delete the rows no longer required, then continue for the next record and so on. This data will having varying rows so ideally need to make sure it can handle that.

Here is a screenshot of the spreadsheet to show you what I mean but I can attach a truncated copy of the file if needed.

First I need just one version of the data in P2:P22 to copies and transposed to R1 to provide headings.
Then need Q2:22 to be transposed to R2. I then need rows 3:22 to be deleted.
Then need to repeat the same for the next invoice number (which is in column A) but it will be on the next row down (Q3:23 transposed to R3, then delete 4:23 to be deleted and so on).

As mentioned this file will have varying rows so need to make sure it captures everything. I thought it might be a mix of an IF formula and transpose but it's a bit beyond what I can get my head around.

I will be adding some formatting to the code but I can add this myself

Thank you in advance!

 

[mumps]

It is hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[jazzhayward]

It is hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Hi Mumps,

Thanks for the tips.

Please see below excerpt:

Copy of SWAU data 160922 - truncated - EDITED.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Transaction Number	Transaction Source	Transaction Class	Transaction Type	Complete	Bill-to Customer	Bill-to Customer Account Number	Transaction Date	Business Unit	Original Transaction Number	Entered Amount	Currency	Due Date	PO Number	Reference	Detail Data
2	51615501A1	cars+	Invoice	Rental Invoice	Yes	XXXX AUSTRALIA	SWAU	03-Sep-2022	XXXX NEW ZEALAND		974.76	NZD	03-Oct-2022		123456789	Context Value	cars+
3																Pay Type	1234xyz
4																Rate	1234abc
5																Driver Name	JOHN SMITH
6																Pickup Location Code and Desc	MEL12 MELBOURNE EARTH
7																Pickup Date and Time	28-AUG-2022 13:24:00
8																DropOff Location Code and Desc	MEL12 MELBOURNE EARTH
9																Drop Off Date and Time	03-SEP-2022 14:20:00
10																Vehicle Charged	K
11																Car Reg. No	VEH123
12																Vehicle Supplied	RED CLOWN CAR
13																Kms Out	13008
14																Kms In	13457
15																Carbon Emissions	76330.00
16																Location Owner Name	XXXX NEW ZEALAND LTD
17																Location Owner GST No.	12-345-XXX
18																Context Value	cars+
19																RA Number	123456789
20																Reservation Number	K12345
21																Voucher Number	ZXYZ123
22																Frequent Flyer
23	51622054A1	cars+	Invoice	Rental Invoice	Yes	XXXX AUSTRALIA	SWAU	12-Sep-2022	XXXX NEW ZEALAND		487.70	NZD	12-Oct-2022		123456789	Context Value	cars+
24																Pay Type	1234xyz
25																Rate	1234abc
26																Driver Name	JOHN SMITH
27																Pickup Location Code and Desc	MEL12 MELBOURNE EARTH
28																Pickup Date and Time	07-SEP-2022 18:09:00
29																DropOff Location Code and Desc	MEL12 MELBOURNE EARTH
30																Drop Off Date and Time	12-SEP-2022 14:10:00
31																Vehicle Charged	F2
32																Car Reg. No	VEH123
33																Vehicle Supplied	RED CLOWN CAR
34																Kms Out	9447
35																Kms In	9954
36																Carbon Emissions	48672.00
37																Location Owner Name	XXXX NEW ZEALAND LTD
38																Location Owner GST No.	12-345-XXX
39																Context Value	cars+
40																RA Number	123456789
41																Reservation Number	K12345
42																Voucher Number	ZXYZ123
43																Frequent Flyer
44	51623800A1	cars+	Invoice	Rental Invoice	Yes	XXXX AUSTRALIA	SWAU	15-Sep-2022	XXXX NEW ZEALAND		396.00	NZD	15-Oct-2022		123456789	Context Value	cars+
45																Pay Type	1234xyz
46																Rate	1234abc
47																Driver Name	JOHN SMITH
48																Pickup Location Code and Desc	MEL12 MELBOURNE EARTH
49																Pickup Date and Time	11-SEP-2022 16:42:00
50																DropOff Location Code and Desc	MEL12 MELBOURNE EARTH
51																Drop Off Date and Time	15-SEP-2022 15:42:00
52																Vehicle Charged	J
53																Car Reg. No	VEH123
54																Vehicle Supplied	RED CLOWN CAR
55																Kms Out	326
56																Kms In	585
57																Carbon Emissions	53354.00
58																Location Owner Name	XXXX NEW ZEALAND LTD
59																Location Owner GST No.	12-345-XXX
60																Context Value	cars+
61																RA Number	123456789
62																Reservation Number	K12345
63																Voucher Number	ZXYZ123
64																Frequent Flyer	HERTZ REWARDS
65	51623585A1	cars+	Invoice	Rental Invoice	Yes	XXXX AUSTRALIA	SWAU	14-Sep-2022	XXXX NEW ZEALAND		570.36	NZD	14-Oct-2022		123456789	Context Value	cars+
66																Pay Type	1234xyz
67																Rate	1234abc
68																Driver Name	JOHN SMITH
69																Pickup Location Code and Desc	MEL12 MELBOURNE EARTH
70																Pickup Date and Time	11-SEP-2022 10:25:00
71																DropOff Location Code and Desc	MEL12 MELBOURNE EARTH
72																Drop Off Date and Time	14-SEP-2022 09:30:00
73																Vehicle Charged	G
74																Car Reg. No	VEH123
75																Vehicle Supplied	RED CLOWN CAR
76																Kms Out	2610
77																Kms In	3081
78																Carbon Emissions	80070.00
79																Location Owner Name	XXXX NEW ZEALAND LTD
80																Location Owner GST No.	12-345-XXX
81																Context Value	cars+
82																RA Number	123456789
83																Reservation Number	K12345
84																Voucher Number	ZXYZ123
85																Frequent Flyer
Export to Excel (2)

As mentioned this file will have varying rows so need to make sure it captures everything. I thought it might be a mix of an IF formula and transpose but it's a bit beyond what I can get my head around.

As mentioned on my original post:
1) Copy data from P2:P22 and transpose to R1 to provide the headings for the the data (this only needs to happen once)
2) For the invoice invoice number (in column A), copy data from Q2:Q22 and transpose to R2 (so it's inline with the invoice number in column A)
3) Delete rows 3:22
4) Then I need to repeat the above steps for the next invoice number (in column A) but the data copied will be Q3:23, transposed to R3, then delete rows 4:23)
5) I need this to be repeated all the way through the spreadsheet until it reaches the bottom. This spreadsheet will have a varying number of lines. The headings will always be the same but the data will be different.

I hope this has described the issue well, please let me know if you need more detail.

Thanks in advanced!

 

[mumps]

Try:

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, fnd1 As Range, sAddr As String, fRow As Long, x As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 2 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            x = Range("A2:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
            Range("A" & fRow).Resize(, 15).Copy Range("A" & x)
        Next i
    End With
    Range("R1").Resize(, 21).Value = WorksheetFunction.Transpose(Range("P2:P22").Value)
    Set fnd1 = Range("P:P").Find("Pay Type", LookIn:=xlValues, LookAt:=xlWhole)
    If Not fnd1 Is Nothing Then
        sAddr = fnd1.Address
        Do
            Cells(Rows.Count, "R").End(xlUp).Offset(1).Resize(, 21).Value = WorksheetFunction.Transpose(Range("Q" & fnd1.Row - 1).Resize(21).Value)
            Set fnd1 = Range("P:P").Find(fnd1, after:=fnd1, LookIn:=xlValues, LookAt:=xlWhole)
        Loop While fnd1.Address <> sAddr
        sAddr = ""
    End If
    Rows(x + 1 & ":" & LastRow).Delete
    Application.ScreenUpdating = True
End Sub

 

[jazzhayward]

Hi Mumps,

Thank for you for the code. I copied it exactly and ran the macro and it works great until it gets to line 22. It looks like it may have grabbed an invoice number from line 2 again, then continued. I can't quite figure it out.

I'm not at home at the moment so can't insert the Excel snip so I'll add when I get home.

Thanks

 

[jazzhayward]

Hi Mumps,

I have put all 3 files in a link that you can look at:

Macro Testing Files

I have the original file, the macro file and then the file after the macro was applied. I have highlighted the errors in orange/yellow.

Hope you can figure it out.

Thanks in advance

 

[mumps]

Try:

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, fnd1 As Range, sAddr As String, fRow As Long, x As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 2 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            x = Range("A2:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
            Range("A" & fRow).Resize(, 15).Cut Range("A" & x)
        Next i
    End With
    Range("R1").Resize(, 21).Value = WorksheetFunction.Transpose(Range("P2:P22").Value)
    Set fnd1 = Range("P:P").Find("Pay Type", LookIn:=xlValues, LookAt:=xlWhole)
    If Not fnd1 Is Nothing Then
        sAddr = fnd1.Address
        Do
            Cells(Rows.Count, "R").End(xlUp).Offset(1).Resize(, 21).Value = WorksheetFunction.Transpose(Range("Q" & fnd1.Row - 1).Resize(21).Value)
            Set fnd1 = Range("P:P").Find(fnd1, after:=fnd1, LookIn:=xlValues, LookAt:=xlWhole)
        Loop While fnd1.Address <> sAddr
        sAddr = ""
    End If
    Rows(x + 1 & ":" & LastRow).Delete
    Application.ScreenUpdating = True
End Sub

 

[jazzhayward]

Hi Mumps - thanks again for your help. Looks like this one works a treat

 

[mumps]

You are very welcome.