Excel Macro to re-format data

[moorej]

I have data in multiple columns that repeats except for one date reference. The X0 column starts with a date and the date updates with the next data reference. I need to move the All data like the reference number in column A down to the next row until all have been moved. Column A is the place holder for the data. The data may repeat many more times than the example. In the example it only repeats 4 times. There are also many more columns of data, but in the example there are only 4.

The macro should run until there is no more data to move. The result should look like the lower example. I'm not sure how I can do this. I can modify a macro created with this example but have no clue as to how to begin to write it.

Any help would be welcome. Thanks in advance.


Data comes in like this

A B C D E F G H I J K L M N O P
NUMA NUMB X0 X0H
101064 670 3/1/2014 0.50 101064 670 4/1/2014 0.50 101064 670 5/1/2014 0.50 101064 670 6/1/2014 0.50
102065 671 3/1/2014 0.50 102065 671 4/1/2014 0.50 102065 671 5/1/2014 0.50 102065 671 6/1/2014 0.50
103067 673 3/1/2014 0.50 103067 673 4/1/2014 0.50 103067 673 5/1/2014 0.50 103067 673 6/1/2014 0.50

Would like to have it look like this

A B C D
NUMA NUMB X0 X0H
101064 670 3/1/2014 0.50
101064 670 4/1/2014 0.50
101064 670 5/1/2014 0.50
101064 670 6/1/2014 0.50
102065 671 3/1/2014 0.50
102065 671 4/1/2014 0.50
102065 671 5/1/2014 0.50
102065 671 6/1/2014 0.50
103067 673 3/1/2014 0.50
103067 673 4/1/2014 0.50
103067 673 5/1/2014 0.50
103067 673 6/1/2014 0.50

 

[Maagaard]

Hi moorej,

This should work, assumin, that you are on the sheet with the data when you start the macro.
Furthermore the data needs to start in row 1.

Sub FormatData()Dim RowC, Lrow, RowR As Integer
Dim OS, TS As Worksheet


Application.ScreenUpdating = Flase


Set TS = ActiveSheet
Set OS = Sheets.Add


Lrow = TS.Range("A" & Rows.Count).End(xlUp).Row


TS.Range("A1:P" & Lrow).Copy
OS.Range("A1").PasteSpecial


TS.Range("A2:P" & Lrow).ClearContents


RowR = 2
For RowC = 2 To Lrow
    OS.Range("A" & RowC & ":D" & RowC).Copy
    TS.Range("A" & RowR).PasteSpecial
    RowR = RowR + 1
    OS.Range("E" & RowC & ":H" & RowC).Copy
    TS.Range("A" & RowR).PasteSpecial
    RowR = RowR + 1
    OS.Range("I" & RowC & ":L" & RowC).Copy
    TS.Range("A" & RowR).PasteSpecial
    RowR = RowR + 1
    OS.Range("M" & RowC & ":P" & RowC).Copy
    TS.Range("A" & RowR).PasteSpecial
    RowR = RowR + 1
Next


Application.DisplayAlerts = False
    OS.Delete
Application.DisplayAlerts = True


Application.ScreenUpdating = True


End Sub

Hope this Helps!

Maagaard

 

[moorej]

Thanks for the response. I was able to make it work but had to filter the records first. The dataset may have been to large for the way the macro worked. The spreadsheet has 234 columns and 4817 rows.

The macro stops with an error to debug. In VB the pointer is at the 6th interval with "RowR = RowR + 1" highlighted.

Looking at one sheet, it stops coping at row 32767.

If there is a way to do it all at once that would be better but I can work with this by filtering the recordset to a smaller number.

Thanks again.

 

[Maagaard]

Ok, I just made it work until column P.

But try and dim rowr as a double instead.

 

[Maagaard]

Try this instead, this should work for any size data set, a bit slower though!

Sub FormatData()Dim RowC, Lrow, ColumnF, ColumnT, Lcol As Double
Dim OS, TS As Worksheet
Dim RowR As Double




Application.ScreenUpdating = Flase




Set TS = ActiveSheet
Set OS = Sheets.Add




Lrow = TS.Range("A" & Rows.Count).End(xlUp).Row
Lcol = TS.Cells(2, Columns.Count).End(xlToLeft).Column


TS.Range(TS.Cells(1, 1), TS.Cells(Lrow, Lcol)).Copy
OS.Range("A1").PasteSpecial




TS.Range(TS.Cells(2, 1), TS.Cells(Lrow, Lcol)).ClearContents




RowR = 2
For RowC = 2 To Lrow
    ColumnF = 1
    Do Until ColumnT >= Lcol
        ColumnT = ColumnF + 3
        OS.Range(OS.Cells(RowC, ColumnF), OS.Cells(RowC, ColumnT)).Copy
        TS.Range("A" & RowR).PasteSpecial
        RowR = RowR + 1
        ColumnF = ColumnF + 4
     Loop
     ColumnT = 4
     ColumnF = 1
Next




Application.DisplayAlerts = False
    OS.Delete
Application.DisplayAlerts = True




Application.ScreenUpdating = True




End Sub

 

[hiker95]

moorej,

Sample raw data:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	NUMA	NUMB	X0	X0H
2	101064	670	3/1/2014	0.50	101064	670	4/1/2014	0.50	101064	670	5/1/2014	0.50	101064	670	6/1/2014	0.50
3	102065	671	3/1/2014	0.50	102065	671	4/1/2014	0.50	102065	671	5/1/2014	0.50	102065	671	6/1/2014	0.50
4	103067	673	3/1/2014	0.50	103067	673	4/1/2014	0.50	103067	673	5/1/2014	0.50	103067	673	6/1/2014	0.50
5
6
7
8
9
10
11
12
13
14
Sheet1

After the macro:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	NUMA	NUMB	X0	X0H
2	101064	670	3/1/2014	0.50
3	101064	670	4/1/2014	0.50
4	101064	670	5/1/2014	0.50
5	101064	670	6/1/2014	0.50
6	102065	671	3/1/2014	0.50
7	102065	671	4/1/2014	0.50
8	102065	671	5/1/2014	0.50
9	102065	671	6/1/2014	0.50
10	103067	673	3/1/2014	0.50
11	103067	673	4/1/2014	0.50
12	103067	673	5/1/2014	0.50
13	103067	673	6/1/2014	0.50
14
Sheet1

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).

Option Explicit
Sub ReorgData()
' hiker95, 01/10/2014, ME749684
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, c As Long
Dim lr As Long, lc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
a = Range(Cells(2, 1), Cells(lr, lc))
ReDim o(1 To UBound(a, 1) * (lc / 4), 1 To 4)
For i = 1 To UBound(a, 1)
  For c = 1 To lc Step 4
    ii = ii + 1
    o(ii, 1) = a(i, c)
    o(ii, 2) = a(i, c + 1)
    o(ii, 3) = a(i, c + 2)
    o(ii, 4) = a(i, c + 3)
  Next c
Next i
Range(Cells(2, 1), Cells(lr, lc)).ClearContents
Range("A2").Resize(UBound(o, 1), UBound(o, 2)) = o
Range("D2:D" & UBound(o, 1)).NumberFormat = "0.00"
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.

 

[moorej]

Thanks for the response.

The macro stops with an error at TS.Range("A" & RowR).PasteSpecial Probably because it reaches the Excel row limit of 65536.

The data is also not formated correctly because it is just copying and moving data in just 4 columns at a time instead of 18 columns at a time. How would the macro need to be updated to copy and move 18 data fields at a time?

Thanks again for your help.

 

[moorej]

Thanks hiker95 for the response.

Running the macro on the sample data works fine. But running on my dataset produces an error at the code o(ii, 3) = a(i, c + 2)

What would need to be updated to copy 18 colums for 13 intervals per row of data?

Thanks again for your help.

 

[hiker95]

moorej,

It is always best to display your actual raw data. This way a solution can be found on the first go.

I will need to see your workbook.

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.


If you are not able to supply your workbook, then:

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

 

[moorej]

Hi hiker95,

I was able to make the macro work by modifying some of the code to the following. I will try to upload a sample workbook with sample data.

ReDim o(1 To UBound(a, 1) * (lc / 18), 1 To 18)
For i = 1 To UBound(a, 1)
For c = 1 To lc Step 18
ii = ii + 1
o(ii, 1) = a(i, c)
o(ii, 2) = a(i, c + 1)
o(ii, 3) = a(i, c + 2)
o(ii, 4) = a(i, c + 3)
o(ii, 5) = a(i, c + 4)
o(ii, 6) = a(i, c + 5)
o(ii, 7) = a(i, c + 6)
o(ii, 8) = a(i, c + 7)
o(ii, 9) = a(i, c + 8)
o(ii, 10) = a(i, c + 9)
o(ii, 11) = a(i, c + 10)
o(ii, 12) = a(i, c + 11)
o(ii, 13) = a(i, c + 12)
o(ii, 14) = a(i, c + 13)
o(ii, 15) = a(i, c + 14)
o(ii, 16) = a(i, c + 15)
o(ii, 17) = a(i, c + 16)
o(ii, 18) = a(i, c + 17)
Next c