ffionnah

Board Regular
Joined
Jun 12, 2018
Messages
61
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 :LOL:. 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.

Code:
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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

RSpin

New Member
Joined
Dec 12, 2018
Messages
31
Have you tried replacing:
Rich (BB code):
 Cells(RL, CL).Select

with:
Rich (BB code):
Cells(RL, CL).Activate


 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,406
Office Version
  1. 365
Platform
  1. Windows
If this line
Code:
Cells(RL, CL).Select
doesn't take you back to the start cell where does it take you?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,406
Office Version
  1. 365
Platform
  1. Windows
Does this do what you want?
Code:
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

Board Regular
Joined
Jun 12, 2018
Messages
61

ADVERTISEMENT

That worked; Thank you so very much! Happy Holidays
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,406
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback
 

ffionnah

Board Regular
Joined
Jun 12, 2018
Messages
61

ADVERTISEMENT

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"
 
Last edited:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,406
Office Version
  1. 365
Platform
  1. Windows
Add this to the end of the code
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

Board Regular
Joined
Jun 12, 2018
Messages
61
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)?
 
Last edited:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,406
Office Version
  1. 365
Platform
  1. Windows
How about
Code:
    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""),"""")"
 

Watch MrExcel Video

Forum statistics

Threads
1,129,288
Messages
5,635,333
Members
416,855
Latest member
niha

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top