Complex row to column help required!

[BaffledOfBristol]

My VBA/macro writing is a little rusty and I need to consolidate multiple rows into one row and then delete the old rows. My vehicle table has 1 row per bus per month. What I am trying to do is change the file so it contains only one row per bus with the monthly data in new columns.


The current columns are as follows (many rows per bus). The underlined columns are static/repeating for each monthly bus row. In bold are the columns that do change per bus per month :-


FLEET NO
REGISTRATION NO
VEHICLE TYPE
MODEL
COMPANY
ALLOCATED DEPOT
CLOSING ODOMETER
ODOMETER DAT
ODOMETER UNIT
FUEL USED IN PERIOD
MILES IN PERIOD
BSOG ELIGIBILITY



What I would like to do is have the data re-arranged as per the following columns with 1 row per bus:-


FLEET NO
REGISTRATION NO
VEHICLE TYPE
MODEL
COMPANY
ALLOCATED DEPOT
CLOSING ODOMETER1
ODOMETER DAT1
FUEL USED IN PERIOD1

MILES IN PERIOD1
CLOSING ODOMETER2
ODOMETER DAT2
FUEL USED IN PERIOD2

MILES IN PERIOD2

....
....
....
CLOSING ODOMETERn
ODOMETER DATn
FUEL USED IN PERIODn

MILES IN PERIODn

ODOMETER UNIT

BSOG ELIGIBILITY



It would be great if I could also order the repeating 'n' group of columns chronologically . Is this possible? The ODOMETER_DAT is in dd/mm/yyyy format.


The monthly data for the buses is not consistent i.e. the buses could have anywhere from one months data (i.e. 1 row) to a years worth (i.e. 12 rows). FLEETNO is the unique identifier for the bus.

Can anyone help please? Many thanks.

 

[hiker95]

BaffledOfBristol,

Sample raw data in worksheet Sheet1 (I am using column M as a work area), before and after the macro:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	FLEET NO	REGISTRATION NO	VEHICLE TYPE	MODEL	COMPANY	ALLOCATED DEPOT	CLOSING ODOMETER	ODOMETER DAT	ODOMETER UNIT	FUEL USED IN PERIOD	MILES IN PERIOD	BSOG ELIGIBILITY
2	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	172989	27-Apr-13	M	2031.8	2614	TRUE
3	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	175235	25-May-13	M	1939.5	2246	TRUE
4	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	175703	29-Jun-13	M	2656.7	3077	TRUE
5	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	178030	27-Jul-13	M	2008.9	2327	TRUE
6	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	179981	24-Aug-13	M	1684.8	1951	TRUE
7	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	179969	28-Sep-13	M	2168.22	2511	TRUE
8	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	182546	26-Oct-13	M	2105.7	2577	TRUE
9	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	168677	29-Dec-12	M	2581.6	3041	TRUE
10	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	168011	26-Jan-13	M	1579.2	1860	TRUE
11	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	170615	23-Feb-13	M	2210.7	2604	TRUE
12	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	173780	30-Mar-13	M	2687	3165	TRUE
13
Sheet1

After the macro in a new worksheet Results:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L
1	FLEET NO	REGISTRATION NO	VEHICLE TYPE	MODEL	COMPANY	ALLOCATED DEPOT	ODOMETER UNIT	BSOG ELIGIBILITY	CLOSING ODOMETER1	ODOMETER DAT1	FUEL USED IN PERIOD1	MILES IN PERIOD1
2	12345	A123ABC	B7TL	VOLVO B7TL	BusCo	Bristol	M	TRUE	168677	29-Dec-12	2581.6	3041
3
Results

All the way out to column AZ:

Excel 2007
	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ
1	CLOSING ODOMETER9	ODOMETER DAT9	FUEL USED IN PERIOD9	MILES IN PERIOD9	CLOSING ODOMETER10	ODOMETER DAT10	FUEL USED IN PERIOD10	MILES IN PERIOD10	CLOSING ODOMETER11	ODOMETER DAT11	FUEL USED IN PERIOD11	MILES IN PERIOD11
2	179981	24-Aug-13	1684.8	1951	179969	28-Sep-13	2168.22	2511	182546	26-Oct-13	2105.7	2577
3
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 12/30/2013
' http://www.mrexcel.com/forum/excel-questions/746813-complex-row-column-help-required.html
Dim w1 As Worksheet, wR As Worksheet
Dim oa As Variant
Dim r As Long, rr As Long, lr As Long, lc As Long, n As Long, nr As Long, nc As Long, c As Long
Set w1 = Sheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Sheets("Results")
With Sheets("Results")
  .UsedRange.ClearContents
   w1.Range("A1:F1").Copy .Range("A1:F1")
   w1.Range("G1").Copy .Range("I1")
   .Range("I1") = .Range("I1") & "1"
   w1.Range("H1").Copy .Range("J1")
   .Range("J1") = .Range("J1") & "1"
   w1.Range("I1").Copy .Range("G1")
   w1.Range("J1").Copy .Range("K1")
   .Range("K1") = .Range("K1") & "1"
   w1.Range("K1").Copy .Range("L1")
   .Range("L1") = .Range("L1") & "1"
   w1.Range("L1").Copy .Range("H1")
End With
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  oa = .Range(.Cells(1, 1), .Cells(lr, lc + 1))
  With .Range("M2:M" & lr)
    .FormulaR1C1 = "=RC[-12]&RC[-11]"
    .Value = .Value
  End With
  .Range("A2:M" & lr).Sort key1:=.Range("M2"), order1:=1, key2:=.Range("H2"), order2:=1
  For r = 2 To lr
    n = Application.CountIf(w1.Columns(13), w1.Cells(r, 13).Value)
    nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    If n = 1 Then
      .Range("A" & r & ":F" & r).Copy wR.Range("A" & nr)
      .Range("G1").Copy wR.Range("I" & nr)
      .Range("H1").Copy wR.Range("J" & nr)
      .Range("I1").Copy wR.Range("G" & nr)
      .Range("J1").Copy wR.Range("K" & nr)
      .Range("K1").Copy wR.Range("L" & nr)
      .Range("L1").Copy wR.Range("H" & nr)
    ElseIf n > 1 Then
      .Range("A" & r & ":F" & r).Copy wR.Range("A" & nr)
      .Range("I" & r).Copy wR.Range("G" & nr)
      .Range("L" & r).Copy wR.Range("H" & nr)
      nc = 9
      For rr = r To r + n - 1
        .Range("G" & rr).Copy wR.Cells(nr, nc)
        .Range("H" & rr).Copy wR.Cells(nr, nc + 1)
        .Range("J" & rr).Copy wR.Cells(nr, nc + 2)
        .Range("K" & rr).Copy wR.Cells(nr, nc + 3)
        nc = nc + 4
      Next rr
    End If
    r = r + n - 1
  Next r
  w1.Range(w1.Cells(1, 1), w1.Cells(lr, lc + 1)) = oa
End With
With wR
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  n = 1
  For c = 13 To lc Step 4
    n = n + 1
    .Cells(1, c) = "CLOSING ODOMETER" & n
    .Cells(1, c + 1) = "ODOMETER DAT" & n
    .Cells(1, c + 2) = "FUEL USED IN PERIOD" & n
    .Cells(1, c + 3) = "MILES IN PERIOD" & n
  Next c
  .Range(.Cells(1, 13), .Cells(1, lc)).WrapText = True
  .Columns.AutoFit
  .Activate
End With
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[BaffledOfBristol]

Many thanks hiker95,

I followed the instructions and ran the code as a module in the spreadsheet. I let it run for 40mins but it didn't complete. The egg timer (or its newest MS name) just kept spinning. The CPU on my laptop was also running constantly at 50% for the excel.exe. I had to kill the process in the end. I didn't think it should take 40mins to go through 75k rows. Could there have been a for loop or something that it got into?

Also in the results sheet, the only columns that were on row1 were the original column headings, not the new repeating 1-n columns.

Can you help please?

 

[BaffledOfBristol]

hiker95,

Please ignore my previous post. I have tried it several more times with different macro security settings and it has now worked.

Many many thanks for all your help!

 

[BaffledOfBristol]

Apologies again, I have gone through the data in the 'results' sheet and found an issue.

The 75k original rows are now down to 8436. Of these 360 have the column headings repeated in columns G-L instead of the data. I have gone through the original data for about 10 of these rows and can't see a pattern that might have triggered it. Can you help please?

 

[hiker95]

BaffledOfBristol,

I would have to see your workbook that is causing the problem.

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[BaffledOfBristol]

Hi Hiker95,

Many thanks for all your help. Unfortunately due to the nature of the data I cannot share it. However the errors are only 3.5% which I will take into consideration within the analysis.

thanks again,

BoB

 

[hiker95]

BaffledOfBristol,

Thanks for the feedback.

You are very welcome.

And, come back anytime.

Sorry I was not able to see your live data to be able to find a solution.