Transpose Data Macro - Question #2

[poleenie]

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 and titer. How do I do that by adding to this macro?

Basically, there are 5 variables instead of 3 originally.


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

 

[joel]

I made the code clear and didn't put the data into an array. I made th
code a little more clear so it is easy to understand.


Sub TransposeIt()


Dim arr As Variant
Dim r As Long
Dim Counter As Long
Dim ID As String
Dim DestRow As Long


DestRow = 1
MaxResults = 0

Set OldSht = ActiveSheet
Set DestSht = Worksheets.Add



With OldSht
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
'sort twice since you can only sort 3 parameters at a time
.Rows("1:" & Lastrow).Sort _
header:=xlNo, _
Key1:=.Range("D1"), _
order1:=xlAscending, _
Key2:=.Range("E1"), _
order2:=xlAscending, _
Key3:=.Range("F1"), _
order3:=xlAscending
.Rows("1:" & Lastrow).Sort _
header:=xlNo, _
Key1:=.Range("A1"), _
order1:=xlAscending, _
Key2:=.Range("B1"), _
order2:=xlAscending, _
Key3:=.Range("C1"), _
order3:=xlAscending

ID = ""
For RowCount = 1 To Lastrow
NewID = .Range("A" & RowCount)
If ID <> NewID Then
ColCount = 2
DestRow = DestRow + 1
ID = NewID
DestSht.Range("A" & DestRow) = ID
ResultsCount = 0
End If

'put header row for new data
ResultsCount = ResultsCount + 1
If ResultsCount > MaxResults Then
With DestSht
MaxResults = ResultsCount
.Cells(1, ColCount) = "Date " & ResultsCount
.Cells(1, ColCount + 1) = "Test " & ResultsCount
.Cells(1, ColCount + 2) = "Result " & ResultsCount
.Cells(1, ColCount + 3) = "TiterA " & ResultsCount
.Cells(1, ColCount + 4) = "TiterB " & ResultsCount
End With
End If

DestSht.Cells(DestRow, ColCount) = .Range("B" & RowCount)
DestSht.Cells(DestRow, ColCount + 1) = .Range("C" & RowCount)
DestSht.Cells(DestRow, ColCount + 2) = .Range("D" & RowCount)
DestSht.Cells(DestRow, ColCount + 3) = .Range("E" & RowCount)
DestSht.Cells(DestRow, ColCount + 4) = .Range("F" & RowCount)
ColCount = ColCount + 5
Next RowCount

MsgBox "Done"

End With
End Su