Complex Search

**thompa2** · 08-05-2014, 06:16 PM

Hello,

Not sure where to start with creating a data filter.

I have a spreadsheet with patient data, each patient having a unique number. Each patient has multiple cancer diagnoses, each one of those with a date. What I want to do is identify all patients who have a second cancer diagnosis within 6 months of their original diagnosis.

Example.JPG

Here's a screenshot of an example of my dataset. The red box represents a patient that had 2 cancer diagnoses within 6 months. These are the people I want to create an automated search for, and then export a list of their Patient IDs.

I'm sorry for noobing out on all of you, just not sure where to start. Thanks.

**mehmetcik** · 08-05-2014, 06:21 PM

Hi

Most of us will not even look at an image of your requirement.

Why would we want to waste our time retyping your data? Sometimes with errors? due to formatting?

But as this is a medical issue I will look at your data.

**mehmetcik** · 08-05-2014, 06:31 PM

Hi

Most of us will not even look at an image of your requirement.

Why would we want to waste our time retyping your data? Sometimes with errors? due to formatting?

But as this is a medical issue I will look at your data.

Ok your requirement is quite simple.

The process is to sort your data to ensure that all your Patiant IDs are in sequence.

In column E enter a formula such as the following for cell E2.

=if(Or(A1=A2,A2=A3),1,0)

Copy and paste values into column E.

Now resort your Data using column E.

Select the part of column E that contains 1's

Expand that selection to the whole row.

Copy the selection into a new sheet.

Now delete column e.

So that is the process.

I will create a fully annotated macro for you, as this is for medical use,

so that you can understand it and can load it your self into your pc.

I will not send you a file, in this instance.

Sub Macro1()
'
' Macro1 Macro
'

'This finds the last used row in your data
    LR = Selection.SpecialCells(xlCellTypeLastCell).Row

'This Part will sort by column A
    Range("A2:G" & LR).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & LR), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("D2:D" & LR), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C" & LR), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec", DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:G" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

'This creates formula in column E highlighting duplicate patiant IDs.
    Range("E2:E" & LR).FormulaR1C1 = "=IF(OR(RC[-4]=R[-1]C[-4],RC[-4]=R[1]C[-4]),1,0)"
   
'This creates a formula in Column F that calculates the number of months between Duplicate Patiant Entries.
    Range("F2:F" & LR).FormulaR1C1 = _
        "=IF(AND(R[-1]C[-5]=RC[-5],RC[-1]=1),(RC[-2]-R[-1]C[-2])*12+MONTH(1&RC[-3])-MONTH(1&R[-1]C[-3]),"""")"
       
'This creates a formula in Column G to highlight Months between 1 and 6
    Range("G2:G" & LR).FormulaR1C1 = _
        "=IF(OR(AND(RC[-2]=1,RC[-1]>0,RC[-1]<7), IF(AND(RC[-6]=R[1]C[-6],R[1]C[-1]>0,R[1]C[-1]<7),1,0)),1,0)"

'This Copies and Pastes values to get rid of the Formulae in your data    
    Range("A2:G" & LR).Value = Range("A2:G" & LR).Value

'This sorts by Column G and then by Column A
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2:G" & LR), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & LR), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:G" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'This finds the first 0 in column G ie the end of our target data
    Range("G2:G" & LR).Select
    Selection.Find(What:="0", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        
'LR is now the end of our target data   
LR = ActiveCell.Row - 1

'We need this in case our Export Sheet does not exist
   On Error Resume Next
   
'Delete the Export Sheet
   Sheets("Export").Delete False
  
'Create a new sheet and name it Export
    Sheets.Add After:=ActiveSheet
    
    ActiveSheet.Name = "Export"

Copy our target Data frok Sheet1 to The new Export Sheet
    Range("A1:D" & LR).Value = Sheets("Sheet1").Range("A1:D" & LR).Value
    Range("E1:E" & LR).Value = Sheets("Sheet1").Range("F1:F" & LR).Value
    Range("E1").Value = "Months"

End Sub

**thompa2** · 08-05-2014, 06:47 PM

Hello,

Thanks for your help. I think I should clarify. I'm not simply looking for a list of unique Patient ID#s. I already found that function in excel

.

What I'm trying to do is more complicated.

This is a list of events. Each row represents a single event, which happens to be a cancer diagnosis. However, every patient has at least 2 events, some have more than 7.

I need a script that will evaluate each event, as a function of each patient, and return a list of patient IDs that only contains that subset of patients who had at least 2 events occurring within 6 months of each other.

Thank you again for helping out.

**mehmetcik** · 08-05-2014, 08:13 PM

This is a better model,

It selects all a patients records if it meets your requirements.


Sub Macro1()
'
' Macro1 Macro
'

'
    Lr = Selection.SpecialCells(xlCellTypeLastCell).Row

    Range("A2:G" & Lr).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & Lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("D2:D" & Lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C" & Lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec", DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:G" & Lr)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

    Range("E2:E" & Lr).FormulaR1C1 = "=IF(OR(RC[-4]=R[-1]C[-4],RC[-4]=R[1]C[-4]),1,0)"
    
    Range("F2:F" & Lr).FormulaR1C1 = _
        "=IF(AND(R[-1]C[-5]=RC[-5],RC[-1]=1),(RC[-2]-R[-1]C[-2])*12+MONTH(1&RC[-3])-MONTH(1&R[-1]C[-3]),"""")"
        
    Range("G2:G" & Lr).FormulaR1C1 = _
        "=IF(AND(RC[-2]=1,RC[-1]>0,RC[-1]<7),1,0)"
    
    Range("A2:G" & Lr).Value = Range("A2:G" & Lr).Value
    Range("H2:H" & Lr).Value = ""

    SR = 2
    
10      If SR > Lr Then GoTo 20
    Range("G" & SR & ":G" & Lr).Select
    Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
        
   SR = ActiveCell.Row + 1
    strValueToPick = ActiveCell.Offset(0, -6).Value
        
    Range("A2:A" & Lr).Select
    Set rngLook = Selection
    

    With rngLook
        Set rngFind = .Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngFind Is Nothing Then
            strFirstAddress = rngFind.Address
            Set rngPicked = rngFind
            Do
                Set rngPicked = Union(rngPicked, rngFind)
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
        End If
    End With
    
    If Not rngPicked Is Nothing Then
        rngPicked.Offset(0, 7).Value = 1
    End If
    
    GoTo 10
    
20      ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("H2:H" & Lr), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & Lr), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:H" & Lr)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
    
    
    
    
     Range("H2:H" & Lr).Select
     Selection.SpecialCells(xlCellTypeBlanks).Select
        
   Lr = ActiveCell.Row - 1
   On Error Resume Next
   
Application.DisplayAlerts = False
   Sheets("Export").Delete
   Application.DisplayAlerts = True
   
    Sheets.Add After:=ActiveSheet
    
    ActiveSheet.Name = "Export"

    Range("A1:D" & Lr).Value = Sheets("Sheet1").Range("A1:D" & Lr).Value
    Range("E1:E" & Lr).Value = Sheets("Sheet1").Range("F1:F" & Lr).Value
    Range("E1").Value = "Months"

End Sub

**thompa2** · 08-06-2014, 04:55 PM

Thanks!!
For some reason your script won't work on my version of Excel (2003) that I use at the hospital, but it works just fine on my version of Excel (2010) I have at home.

**mehmetcik** · 08-06-2014, 05:46 PM

Unfortunately I cannot help you identify the problem area.

If you could step through the macro and tell me where it fails then I can create a work around.

**thompa2** · 08-07-2014, 10:38 AM

When I step through, it fails on line 11: Run-Time Error 1004: Application-defined or object-defined error

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

Edit: It looks like the problem is the Sort fxn, it doesn't exist in Excel 2003, wasn't put in until Excel 2007.

**mehmetcik** · 08-07-2014, 01:23 PM

Try deleting this line completely.

And try running the macro again.

I recorded the sort part of the macro,

there are often redundant lines in the recorded macros.

If that does not work then record yourself doing the search

and insert that instead of my sort routine, after modifying the cell references.

Complex Search

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Re: Complex Search

Thread Information

Users Browsing this Thread

Similar Threads

Complex Search and Find

Complex search problem

[SOLVED] Use FIND in VBA for complex search

Complex Search Criteria

[SOLVED] Creating a complex search

Bookmarks

Bookmarks

Posting Permissions