Transpose data macro

[Pauline Han]

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

 

[Lars-Åke Aspelin]

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

 

[Pauline Han]

Perfect! Thank you so much.

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

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?

   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 -

 

[poleenie]

What happens if I were to add another column? How does this part
change?

Perfect! Thank you so much.

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

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 -