Copy data from rows to columns based on criteria

[KevNewton29]

I recently posted a thread whereby I have a listy of 15,500 entries of policy numbers and the funds invested in these policies. However each seperate fund had a seperate row on Excel (i.e. a policy with four funds had four rows on Excel). What I have been trying to do is have one row with multiple columns for the funds. So far I have code (see below) that does this apart form cases where I only have one fund

Sub test()

Dim rng As Range, r As Long, c As Long, i As Long

' Puts results on sheet2

r = 1
c = 2

With Sheet2
.UsedRange.Clear
.Range("A1:B1").Value = [{"Plan No","Plan No2"}]
End With

Sheet1.Activate
' Change column in following lines if J used for something
Columns("J").Clear
Range("A1", Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
For Each rng In Range("J2", Range("J2").End(xlDown))
Sheet2.Cells(r + 1, 1) = rng
r = r + 1
Next rng

r = 1

For Each rng In Range("A2", Range("A2").End(xlDown))
If rng = rng.Offset(-1) Then
rng.Offset(, 1).Resize(, 2).Copy Sheet2.Cells(r + 1, c)
c = c + 2
Else
r = r + 1
c = 2
End If
Next rng
Columns("J").Clear

End Sub

I then tried to improve on this to look at only one policy line with the code belwo but it doesn't work. Any ideas?

Sub test2()

Dim rng As Range, r As Long, c As Long, i As Long

' Puts results on sheet2

r = 1
c = 2

With Sheet2
.UsedRange.Clear
.Range("A1:B1").Value = [{"Plan No","Plan No2"}]
End With

Sheet1.Activate
' Change column in following lines if J used for something
Columns("J").Clear
Range("A1", Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
For Each rng In Range("J2", Range("J2").End(xlDown))
Sheet2.Cells(r + 1, 1) = rng
r = r + 1
Next rng

r = 1

For Each rng In Range("A2", Range("A2").End(xlDown))
If rng = rng.Offset(-1) Or rng.Offset(1) Then
rng.Offset(, 1).Resize(, 2).Copy Sheet2.Cells(r + 1, c)
c = c + 2
Else
If rng <> rng.Offset(-1) And rng.Offset(1) Then
rng.Offset(, 1).Resize(, 2).Copy Sheet2.Cells(r + 1, c)
Else
r = r + 1
c = 2
End If
End If
Next rng
Columns("J").Clear

End Sub