Sorting contents from columns to Rows [Closed]

Report
Posts
1
Registration date
Tuesday October 21, 2014
Status
Member
Last seen
October 21, 2014
-
Posts
2693
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
January 18, 2021
-
Hi,

I have data sets in particular file format.

Total no: of rows : 3623 (Column A)
Total no: of rate cards: 26 (Column E)
Rates for each code name in particular rate card (Column F)

Codename DisplayText ID Type RateName Rates
17OHP 17 OH Progesterone 4720 INV RPP 260
5HIAA 5-Hydroxy-indole Acetic Acid 4425 INV RPP 360
17OHP 17 OH Progesterone 4720 INV UMSC 0
5HIAA 5-Hydroxy-indole Acetic Acid 4425 INV UMSC 0
17OHP 17 OH Progesterone 4720 INV Dr Price 130
5HIAA 5-Hydroxy-indole Acetic Acid 4425 INV Dr Price 180
17OHP 17 OH Progesterone 4720 INV Alpha SC 168
5HIAA 5-Hydroxy-indole Acetic Acid 4425 INV Alpha SC 232
17OHP 17 OH Progesterone 4720 INV Lab Referral 149
5HIAA 5-Hydroxy-indole Acetic Acid 4425 INV Lab Referral 206

I need to sort this into following format


Code Name RPP UMSC Dr Price Alpha SC Lab Referral
17OHP 260 0 130 168 149
5HIAA 360 0 180 232 206



Thanks in Advance.

1 reply

Posts
2693
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
January 18, 2021
455
Hi Ganeshkrish,

Source sheet is named Sheet1.
Destination sheet is named Sheet2.

Sheet2 should contain header as well as the unique codenames.
Using your sample data, Sheet2 looks like:
Code Name RPP UMSC Dr Price Alpha SC Lab Referral
17OHP
5HIAA


When you have met the above criteria, then try the code below:
Sub RunMe()
Dim lRow As Integer

Sheets("Sheet1").Select
lRow = Range("A1").End(xlDown).Row
x = 2

Do
    For Each cell In Range("A2:A" & lRow)
        If cell = Sheets("Sheet2").Cells(x, "A") Then
            Sheets("Sheet2").Cells(x, Columns.Count).End(xlToLeft).Offset(0, 1) = cell.Offset(0, 5)
        End If
    Next cell
    
    x = x + 1
Loop Until IsEmpty(Sheets("Sheet2").Cells(x, "A"))

End Sub


Best regards,
Trowa

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!