Macro - return to original cell

[ffionnah]

Hi all,
Happy Holidays and thank you in advance for you help. I have a macro I use to identify a unique count for patient names. The goal of this macro is to apply a number to each unique name/dob combination. I have another macro I use to choose a randomized list of numbers within the range of the first macro. (10 unique names, choose 4 randomized numbers between 1 and 10).

What I have been trying to do is combine these macros into one step. The issue I am encountering is having the 2nd macro (randomized list) place the randomized number selection where I need it to be on the spreadsheet, which would be in column AQ, and starting at the corresponding row from the original active cell.

For example; if the original active cell is B5, I would want the randomized list to produce the number selection in AQ5. This would occur after the first portion of the macro goes through all of the names/dob; It continues to count until it reaches a blank cell. I'm not sure how to make the macro return to the original cell (B5) in order to have the second portion of the macro place the randomized number in the corresponding row (AQ5).

I tried adding Cells(RL, CL).Select but that didnt work . I also tried to adjust this line, but that really didnt work either: ActiveCell.Offset(RL, 41).Resize(Num).Value = Out


Below includes both macros together.

Sub IdentifyUniquePT()    Dim RL As Long, CL As Integer
    RL = ActiveCell.Row
    CL = ActiveCell.Column
    
    Range(ActiveCell, ActiveCell.Offset(1, 0)).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    
    CurrentPatientNumber = 1
    ActiveCell.Offset(0, 40).Value = CurrentPatientNumber
    
    Do Until ActiveCell.Value = Empty
       CurrentFN = ActiveCell.Value
       CurrentLN = ActiveCell.Offset(0, 1).Range("A1").Value
       CurrentDOB = ActiveCell.Offset(0, 2).Range("A1").Value
       CurrentRow = ActiveCell.Row
       
       Do Until Not (ActiveCell.Offset(1, 0).Range("A1").Value = CurrentFN And ActiveCell.Offset(1, 1).Range("A1").Value = CurrentLN And ActiveCell.Offset(1, 2).Range("A1").Value = CurrentDOB)
          ActiveCell.Offset(1, 0).Select
          ActiveCell.Offset(0, 40).Value = CurrentPatientNumber
       Loop
       
       ActiveCell.Offset(1, 0).Range("A1").Select
       If Not (ActiveCell.Value = Empty) Then
          CurrentPatientNumber = CurrentPatientNumber + 1
          ActiveCell.Offset(0, 40).Value = CurrentPatientNumber
       End If
    Loop
    MsgBox "Total number of patients = " & CurrentPatientNumber
    TwentyfivePercentOfPatients = 0.25 * CurrentPatientNumber
    MsgBox "To audit " & TwentyfivePercentOfPatients


Cells(RL, CL).Select


Dim PT As Double, Num As Double, Wk() As Double, Out() As Double, x As Long, Y As Long, Q As Long
    
    PT = InputBox("Enter The Total Unique Names", "Enter a Number")
    Num = InputBox("Enter The 25% ", "Enter a Number")
    If Num > PT Then
        MsgBox "The sample size must be less than the total size."
        Exit Sub
    End If
    ReDim Wk(1 To PT)
    ReDim Out(1 To Num, 1 To 1)
    
    For x = 1 To PT
        Wk(x) = x
    Next x
    For x = 1 To Num
        Y = Int(PT * rnd) + 1
        Out(x, 1) = Wk(Y)
        Wk(Y) = Wk(PT)
        PT = PT - 1
    Next x
    
    
    ActiveCell.Offset(RL, 41).Resize(Num).Value = Out
    
End Sub

 

[RSpin]

Have you tried replacing:

 Cells(RL, CL).Select

with:

Cells(RL, CL).Activate

 

[Fluff]

If this line

Cells(RL, CL).Select

doesn't take you back to the start cell where does it take you?

 

[Fluff]

Does this do what you want?

Sub IdentifyUniquePT()
   Dim StartCl As Range, Cl As Range
   Dim CurrentPatientNumber As Long, TwentyfivePercentOfPatients As Double
   Dim PT As Double, Num As Double, Wk() As Double, Out() As Double, x As Long, Y As Long, Q As Long

   Set StartCl = ActiveCell
   CurrentPatientNumber = 1
   For Each Cl In Range(StartCl.Offset(1), StartCl.End(xlDown))
      Cl.Offset(, 40).Value = CurrentPatientNumber
      If Not (Cl.Offset(1) = Cl And Cl.Offset(1, 1) = Cl.Offset(, 1) And Cl.Offset(1, 2) = Cl.Offset(, 2)) Then
         CurrentPatientNumber = CurrentPatientNumber + 1
      End If
   Next Cl
    MsgBox "Total number of patients = " & CurrentPatientNumber
    TwentyfivePercentOfPatients = 0.25 * CurrentPatientNumber
    MsgBox "To audit " & TwentyfivePercentOfPatients


    
    PT = CurrentPatientNumber 'InputBox("Enter The Total Unique Names", "Enter a Number")
    Num = TwentyfivePercentOfPatients 'InputBox("Enter The 25% ", "Enter a Number")
    If Num > PT Then
        MsgBox "The sample size must be less than the total size."
        Exit Sub
    End If
    ReDim Wk(1 To PT)
    ReDim Out(1 To Num, 1 To 1)
    
    For x = 1 To PT
        Wk(x) = x
    Next x
    For x = 1 To Num
        Y = Int(PT * Rnd) + 1
        Out(x, 1) = Wk(Y)
        Wk(Y) = Wk(PT)
        PT = PT - 1
    Next x
    
    
    StartCl.Offset(1, 41).Resize(Num).Value = Out
    
End Sub

 

[ffionnah]

That worked; Thank you so very much! Happy Holidays

 

[Fluff]

You're welcome & thanks for the feedback

 

[ffionnah]

I have another piece i would like to add to this if possible.... It may be too much haha

In response to these 2 generated numbers, i have this formula: =IFERROR(IF(MATCH(AP2,$AQ$2:$AQ$6,0),"yes","no"),"")

Is there a way to add to this macro and have the formula pasted into AR for within the same range; The $AQ$:$AQ$ within the formula above would be the same range used in the original macro (before it reaches a blank)

essentially if any of the unique number are within the randomized list, then make the corresponding cell in AR say "yes"

 

[Fluff]

Add this to the end of the code

    StartCl.Offset(1, 42).Resize(Num).FormulaR1C1 = "=IFERROR(IF(MATCH(rc[-2],r" & StartCl.Row & "c[-1]:r" & CLng(Num) & "c[-1],0),""yes"",""no""),"""")"

 

[ffionnah]

Thank you for the reply!

How do i make this select the randomized group numbers? Currently, when the macro is run for the first group, the formula is grabs AQ1 and AQ2. AQ1 is the header row.. How would i make this grab the randomized group only? AQ2:AQ3. The next group would be AQ18:AQ20... is there a way to make it select the group based on the active cell row, and grab the data until it reaches a blank? (Do Until)

How do i also make this continue to fill in the formula for all cells, moving down(similar to how the original formula fills in numbers until the patient name is a blank cell)?

 

[Fluff]

How about

    Range(StartCl.Offset(1, 42), StartCl.End(xlDown).Offset(, 42)).FormulaR1C1 = "=IFERROR(IF(MATCH(rc[-2],r" & StartCl.Row & "c[-1]:r" & CLng(Num) & "c[-1],0),""yes"",""no""),"""")"