|
Transpose data macro
I have a dataset with multiple records per ID:
ID date test result 1 1 1 2 2 2 3 3 I want to make it into a dataset like this so that there are unique IDs: ID date1 test1 result1 date2 test2 result2 1 2 3 etc. I have this macro that does it for ID, date and test, but I want to add result. How do I do that by adding to this macro? ------------------------------ Sub TransposeIt() Dim arr As Variant Dim r As Long Dim Counter As Long Dim ID As String Dim DestRow As Long [a1].Sort Key1:=[a1], Order1:=xlAscending, Key2:=[b1], Order2:=xlAscending, Header:=xlYes arr = ActiveSheet.UsedRange.Value Worksheets.Add [a1] = "ID" DestRow = 1 For r = 2 To UBound(arr, 1) If arr(r, 1) < ID Then DestRow = DestRow + 1 Cells(DestRow, 1) = arr(r, 1) ID = arr(r, 1) Counter = 0 End If Counter = Counter + 1 Cells(1, Counter * 2) = "Date" & Counter Cells(1, Counter * 2 + 1) = "Test" & Counter Cells(DestRow, Counter * 2) = arr(r, 2) Cells(DestRow, Counter * 2 + 1) = arr(r, 3) Next MsgBox "Done" End Sub ------------------------------------------------------ Any help would be much appreciated!!! Pauline |
Transpose data macro
On Mon, 2 Nov 2009 13:36:00 -0800 (PST), Pauline Han
wrote: I have a dataset with multiple records per ID: ID date test result 1 1 1 2 2 2 3 3 I want to make it into a dataset like this so that there are unique IDs: ID date1 test1 result1 date2 test2 result2 1 2 3 etc. I have this macro that does it for ID, date and test, but I want to add result. How do I do that by adding to this macro? ------------------------------ Sub TransposeIt() Dim arr As Variant Dim r As Long Dim Counter As Long Dim ID As String Dim DestRow As Long [a1].Sort Key1:=[a1], Order1:=xlAscending, Key2:=[b1], Order2:=xlAscending, Header:=xlYes arr = ActiveSheet.UsedRange.Value Worksheets.Add [a1] = "ID" DestRow = 1 For r = 2 To UBound(arr, 1) If arr(r, 1) < ID Then DestRow = DestRow + 1 Cells(DestRow, 1) = arr(r, 1) ID = arr(r, 1) Counter = 0 End If Counter = Counter + 1 Cells(1, Counter * 2) = "Date" & Counter Cells(1, Counter * 2 + 1) = "Test" & Counter Cells(DestRow, Counter * 2) = arr(r, 2) Cells(DestRow, Counter * 2 + 1) = arr(r, 3) Next MsgBox "Done" End Sub ------------------------------------------------------ Any help would be much appreciated!!! Pauline Try replaceing these four rows Cells(1, Counter * 2) = "Date" & Counter Cells(1, Counter * 2 + 1) = "Test" & Counter Cells(DestRow, Counter * 2) = arr(r, 2) Cells(DestRow, Counter * 2 + 1) = arr(r, 3) with these six rows Cells(1, Counter * 3 - 1) = "Date" & Counter Cells(1, Counter * 3) = "Test" & Counter Cells(1, Counter * 3 + 1) = "Result" & Counter Cells(DestRow, Counter * 3 - 1) = arr(r, 2) Cells(DestRow, Counter * 3) = arr(r, 3) Cells(DestRow, Counter * 3 + 1) = arr(r, 4) Hope this helps / Lars-Åke |
Transpose data macro
Perfect! Thank you so much. :)
On Nov 2, 5:07*pm, Lars-Åke Aspelin wrote: On Mon, 2 Nov 2009 13:36:00 -0800 (PST), Pauline Han wrote: I have a dataset with multiple records per ID: ID date test result 1 1 1 2 2 2 3 3 I want to make it into a dataset like this so that there are unique IDs: ID date1 test1 result1 date2 test2 result2 1 2 3 etc. I have this macro that does it for ID, date and test, but I want to add result. How do I do that by adding to this macro? ------------------------------ Sub TransposeIt() * *Dim arr As Variant * *Dim r As Long * *Dim Counter As Long * *Dim ID As String * *Dim DestRow As Long * *[a1].Sort Key1:=[a1], Order1:=xlAscending, Key2:=[b1], Order2:=xlAscending, Header:=xlYes * *arr = ActiveSheet.UsedRange.Value * *Worksheets.Add * *[a1] = "ID" * *DestRow = 1 * *For r = 2 To UBound(arr, 1) * * * *If arr(r, 1) < ID Then * * * * * *DestRow = DestRow + 1 * * * * * *Cells(DestRow, 1) = arr(r, 1) * * * * * *ID = arr(r, 1) * * * * * *Counter = 0 * * * *End If * * * *Counter = Counter + 1 * * * *Cells(1, Counter * 2) = "Date" & Counter * * * *Cells(1, Counter * 2 + 1) = "Test" & Counter * * * *Cells(DestRow, Counter * 2) = arr(r, 2) * * * *Cells(DestRow, Counter * 2 + 1) = arr(r, 3) * *Next * *MsgBox "Done" End Sub ------------------------------------------------------ Any help would be much appreciated!!! Pauline Try replaceing these four rows Cells(1, Counter * 2) = "Date" & Counter Cells(1, Counter * 2 + 1) = "Test" & Counter Cells(DestRow, Counter * 2) = arr(r, 2) Cells(DestRow, Counter * 2 + 1) = arr(r, 3) with these six rows Cells(1, Counter * 3 - 1) = "Date" & Counter Cells(1, Counter * 3) = "Test" & Counter Cells(1, Counter * 3 + 1) = "Result" & Counter Cells(DestRow, Counter * 3 - 1) = arr(r, 2) Cells(DestRow, Counter * 3) = arr(r, 3) Cells(DestRow, Counter * 3 + 1) = arr(r, 4) Hope this helps / Lars-Åke- Hide quoted text - - Show quoted text - |
Transpose data macro
What happens if I were to add another column? How does this part
change? Cells(1, Counter * 3 - 1) = "Date" & Counter Cells(1, Counter * 3) = "Test" & Counter Cells(1, Counter * 3 + 1) = "Result" & Counter Cells(DestRow, Counter * 3 - 1) = arr(r, 2) Cells(DestRow, Counter * 3) = arr(r, 3) Cells(DestRow, Counter * 3 + 1) = arr(r, 4) On Nov 2, 5:15*pm, Pauline Han wrote: Perfect! Thank you so much. :) On Nov 2, 5:07*pm, Lars-Åke Aspelin wrote: On Mon, 2 Nov 2009 13:36:00 -0800 (PST), Pauline Han wrote: I have a dataset with multiple records per ID: ID date test result 1 1 1 2 2 2 3 3 I want to make it into a dataset like this so that there are unique IDs: ID date1 test1 result1 date2 test2 result2 1 2 3 etc. I have this macro that does it for ID, date and test, but I want to add result. How do I do that by adding to this macro? ------------------------------ Sub TransposeIt() * *Dim arr As Variant * *Dim r As Long * *Dim Counter As Long * *Dim ID As String * *Dim DestRow As Long * *[a1].Sort Key1:=[a1], Order1:=xlAscending, Key2:=[b1], Order2:=xlAscending, Header:=xlYes * *arr = ActiveSheet.UsedRange.Value * *Worksheets.Add * *[a1] = "ID" * *DestRow = 1 * *For r = 2 To UBound(arr, 1) * * * *If arr(r, 1) < ID Then * * * * * *DestRow = DestRow + 1 * * * * * *Cells(DestRow, 1) = arr(r, 1) * * * * * *ID = arr(r, 1) * * * * * *Counter = 0 * * * *End If * * * *Counter = Counter + 1 * * * *Cells(1, Counter * 2) = "Date" & Counter * * * *Cells(1, Counter * 2 + 1) = "Test" & Counter * * * *Cells(DestRow, Counter * 2) = arr(r, 2) * * * *Cells(DestRow, Counter * 2 + 1) = arr(r, 3) * *Next * *MsgBox "Done" End Sub ------------------------------------------------------ Any help would be much appreciated!!! Pauline Try replaceing these four rows Cells(1, Counter * 2) = "Date" & Counter Cells(1, Counter * 2 + 1) = "Test" & Counter Cells(DestRow, Counter * 2) = arr(r, 2) Cells(DestRow, Counter * 2 + 1) = arr(r, 3) with these six rows Cells(1, Counter * 3 - 1) = "Date" & Counter Cells(1, Counter * 3) = "Test" & Counter Cells(1, Counter * 3 + 1) = "Result" & Counter Cells(DestRow, Counter * 3 - 1) = arr(r, 2) Cells(DestRow, Counter * 3) = arr(r, 3) Cells(DestRow, Counter * 3 + 1) = arr(r, 4) Hope this helps / Lars-Åke- Hide quoted text - - Show quoted text -- Hide quoted text - - Show quoted text - |
| All times are GMT +1. The time now is 08:44 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com