Extract Data from Adjacent Cell - Two Deep

[drmingle]

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]EncID[/TD]
[TD]Admit Date[/TD]
[TD]Discharge Date[/TD]
[TD]Service Count[/TD]
[TD]Service Hit[/TD]
[/TR]
[TR]
[TD]1231[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]7[/TD]
[TD]OBGYN[/TD]
[/TR]
[TR]
[TD]1232[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]7[/TD]
[TD]OBGYN[/TD]
[/TR]
[TR]
[TD]1233[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]6[/TD]
[TD]OBGYN[/TD]
[/TR]
[TR]
[TD]1234[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]6[/TD]
[TD]Heart[/TD]
[/TR]
[TR]
[TD]1235[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]5[/TD]
[TD]Heart[/TD]
[/TR]
[TR]
[TD]1236[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]5[/TD]
[TD]Lung[/TD]
[/TR]
[TR]
[TD]1237[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]5[/TD]
[TD]Lung[/TD]
[/TR]
[TR]
[TD]1238[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]4[/TD]
[TD]Lung[/TD]
[/TR]
[TR]
[TD]1239[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]4[/TD]
[TD]Lung[/TD]
[/TR]
[TR]
[TD]1240[/TD]
[TD]1/1/2011[/TD]
[TD]1/15/2011[/TD]
[TD]4[/TD]
[TD]Maternity[/TD]
[/TR]
</tbody>[/TABLE]

I am needing vba code to do the following:

• Pull back the first two EncIDs per service (OBGYN, Heart, etc) and place it in another sheet one after the other (not in the same cell)

For example, I would the below outcome for the data I have supplied:
1231
1232
1234
1235
1236
1237
1240

Thank you in advance for your help.

 

[drmingle]

One method I thought about doing was to unique the list first to create a set of values to search for using a vlookup. but my logic breaks down when I have to account for two or more OBGYN, Heart, etc...

How do I use a vlookup to capture the first ID and then capture the next in the series of the group I have referenced (i.e. OBGYN, Heart,etc)?

 

[Mohammad Basem]

Try this,

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Option Explicit

Sub EncID()

    Dim lRow As Long
    Dim bCount As Byte
    Dim sServiceHit As String
    Dim rRange As Range, rCell As Range
    Dim ws As Worksheet

    Sheets("Sheet1").Select
    Set ws = Sheets("Sheet2")
    ws.Range("A1") = "EncID"
    Set rRange = Range("A2", Range("A" & Rows.Count).End(xlUp))

    lRow = 2
    For Each rCell In rRange
        If sServiceHit <> rCell.Offset(, 4) Then
           sServiceHit = rCell.Offset(, 4)
           bCount = 0
        End If
        If bCount < 2 Then
            ws.Cells(lRow, "A") = rCell
            bCount = bCount + 1
            lRow = lRow + 1
        End If
    Next rCell

End Sub[/COLOR][/SIZE][/FONT]

 

[drmingle]

Below is my unique list code and my rearrange code. I have the vlookup code on the worksheet itself which references the unique list. The only problem I am having now is that I am pulling back one EncID value per category and I need 2. I know vlookup alone will not be able to complete this, but I am at a loss for what could resolve this...

Sub Shrink()
'
' Shrink Macro: Create a unique list; Clean up list on active sheet; deposit new list on sheet
'

'
    Range("E2:E11").Select
    Sheets("Data").Select
    Range("E1:E11").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "G2"), Unique:=True
    Range("G2:G6").Select
    Selection.Cut
    Sheets("Chouse").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Data").Select
    Range("E1").Select
End Sub
Sub A_RearrangeData()
'
' A_RearrangeData Macro
'

'
    Range("A1:D11").Select
    Selection.Cut Destination:=Range("F1:I11")
    Range("F1:I11").Select
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Range("I5").Select
End Sub

 

[drmingle]

Mohammed Basem

Perfect solution....

Works like a charm!

 

[Mohammad Basem]

Al-hamdullah, thank you for the feedback!