Escanaba
asked on
Excel 2007 Macro To Move Multiple Rows Into One Row
Hello,
Im hoping someone can assist in designed a macro. In the attached spreadsheet there are two unique identifying columns (A & T). I need a macro that starts in row 2, looks at the data in columns A2 & T2 and then any of the following rows in the spreadsheet that match that combination of data in A2 & T2 will cut the row and paste it at the end of row 2 and repeat the process.
So looking at the sample, the code will look at row 2 columns A & T then see there is a match in rows 3-5 and in row 9. The code would take each of those rows, cut and then paste at the end of row 2 so all of those occurances now appear on one row. Then it repeats the process. I need to get a number of rows, all for the same individual but with different pieces of data, consolidated into one row.
On the attached sample it shows how the file looks before the macro is ran (sheet 1) and how it should look after the macro is ran. Keep in mind after the cut & paste the empty rows would need to be deleted. Also, this is only a sample but the actual spreadsheet will have over 200,000 rows of data. I am certainly up for suggestions if someone has an easier way of putting this together.
Thanks!
EE-Sample.xlsx
Im hoping someone can assist in designed a macro. In the attached spreadsheet there are two unique identifying columns (A & T). I need a macro that starts in row 2, looks at the data in columns A2 & T2 and then any of the following rows in the spreadsheet that match that combination of data in A2 & T2 will cut the row and paste it at the end of row 2 and repeat the process.
So looking at the sample, the code will look at row 2 columns A & T then see there is a match in rows 3-5 and in row 9. The code would take each of those rows, cut and then paste at the end of row 2 so all of those occurances now appear on one row. Then it repeats the process. I need to get a number of rows, all for the same individual but with different pieces of data, consolidated into one row.
On the attached sample it shows how the file looks before the macro is ran (sheet 1) and how it should look after the macro is ran. Keep in mind after the cut & paste the empty rows would need to be deleted. Also, this is only a sample but the actual spreadsheet will have over 200,000 rows of data. I am certainly up for suggestions if someone has an easier way of putting this together.
Thanks!
EE-Sample.xlsx
My immediate question would be: why do you want to arrange your data this way? It will make it much more difficult to analyse in Excel.
ASKER
I understand. The reason I need it set up in such a manner is this data is going through 3 stages. The first stage assembles the data in a complicated piece of software based on business rules and spits it out into Excel. I need the macro to pull the data into single rows so statiscial software can use this data for its own reporting purposes. Based on the end-users needs, they have indicated it has to be in this single row format in order for their software to use it.
I'll have a look later, but anyone else feel free to pop in in the meantime.
ASKER
Greatly appreciate any input. Thanks StephenJR
This doesn't seem to be quite working, but can't immediately see what the problem is. It runs but gives different output from your example - perhaps you could have a look and see if you can see where the error lies?
Sub x()
Dim c As Long, vOut(), vIn(), i As Long, j As Long, n As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Sheets("Before")
c = .Range("A1").CurrentRegion.Columns.Count
.Range("A1").Resize(, c).Copy Sheets("After").Range("A1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, c)
.Formula = "=A2&T2"
.Value = .Value
End With
vIn = .Range("A1").CurrentRegion.Value
.Columns(c + 1).Clear
End With
ReDim vOut(1 To UBound(vIn, 1))
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(vIn, 1)
If Not .Exists(vIn(i, c + 1)) Then
n = n + 1
For j = 1 To c
vOut(n) = vOut(n) & "#" & vIn(i, j)
Next j
If Left(vOut(n), 1) = "#" Then vOut(n) = Mid(vOut(n), 2)
.Add vIn(i, c + 1), n
ElseIf .Exists(vIn(i, c + 1)) Then
For j = 1 To c
vOut(.Item(vIn(i, c + 1))) = vOut(.Item(vIn(i, c + 1))) & "#" & vIn(i, j)
Next j
If Left(vOut(.Item(vIn(i, c + 1))), 1) = "#" Then
vOut(.Item(vIn(i, c + 1))) = Mid(vOut(.Item(vIn(i, c + 1))), 2)
End If
End If
Next i
End With
For j = 1 To n
Sheets("After").Range("A1").Offset(j) = vOut(j)
Next j
Sheets("After").Range("A2").Resize(n).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Other:=True, OtherChar:="#"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
ASKER
StephenJR - Thanks for your patience. I've been working on testing this out against a much larger data set and it's taking me a while to determine results. I'll get back with you shortly to let you know if I ran into problems.
ASKER
StephenJR - Thank you for being so patient while I was testing this out. It appears the code is not treating blank cells properly. If it encounters a blank cell in the row its taken the next available data to the right of that cell and pasting it in which is throwing everything off. Columns E, X:Z & AB:AD are typically blank and where I can see the code is throwing the data alignment off. Im not sure how to correct this in your code and hoping you might.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
StephenJR - Thank you for being patient. It has been unbelievably busy and this sliped away from me. Based on your last code recommendation and tweeks of my own its running fine now. Thank you for putting this together!