Code to move rows into another sheet based on certain valuesSolved/Closed

Question

Hello, 

I've seen different variations on this question, but haven't seen any answers that specifically address moving rows based on multiple values in a single cell (an OR situation). I have an excel spreadsheet to track patient recruitment effort for a clinical trial. Each row contains information about a different patient, and column AH contains outcome options from a list of defined values. 

I would like to move rows from the first sheet ("Master") to the second sheet ("Failed") when the outcome in column AH is ANY of the following: "Phone Screen - Failed" or "Phone Screen - Not Interested" or "Prescreen Fail", and then delete the row from Sheet 1 ("Master"). The following VBA code worked great for moving rows based on just the first term ("Phone Screen - Failed") (thank you internet!). Is there a way to update it so that I can automate the move based on the multiple terms (so that a row with any of these outcomes will be moved to the "Failed" sheet)? 

Sub MoveBasedOnValue()

Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long

A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Failed").UsedRange.Rows.Count

If B = 1 Then

If Application.WorksheetFunction.CountA(Worksheets("Failed").UsedRange) = 0 Then B = 0

End If

Set xRg = Worksheets("Master").Range("AH1:AH" & A)

On Error Resume Next

Application.ScreenUpdating = False

For C = 1 To xRg.Count

If CStr(xRg(C).Value) = "Phone Screen - Failed" Then

xRg(C).EntireRow.Copy Destination:=Worksheets("Failed").Range("A" & B + 1)

xRg(C).EntireRow.Delete

If CStr(xRg(C).Value) = "Phone Screen - Failed" Then

C = C - 1

End If

B = B + 1

End If

End Sub

As a follow up, I'd love to move the rows for the patients who passed screening criteria into a separate sheet. Can I add another module (updating the above code as needed) to accomplish this, too? Or do I just add new lines of code to the existing module? Or something else?

Many thanks!

System Configuration: Windows / Firefox 93.0

vcoolio · Answer

Hello jcbbach,

The following code should do both the tasks for you:-

Option Explicit
Sub BachTest()

Dim ar As Variant, i As Long, wsD As Worksheet
        Dim wsM As Worksheet: Set wsM = Sheets("Master")
        ar = [{"Failed","Failed","Failed","Passed";"Phone Screen - Failed", "Phone Screen - Not Interested", "Prescreen Fail","Passed"}]

Application.ScreenUpdating = False
        
        For i = 1 To UBound(ar, 2)
              Set wsD = Sheets(ar(1, i))
              With wsM.[A1].CurrentRegion
                  .AutoFilter 34, ar(2, i)
                  .Offset(1).EntireRow.Copy wsD.Range("A" & Rows.Count).End(3)(2)
                  .Offset(1).EntireRow.Delete
                  .AutoFilter
                  wsD.Columns.AutoFit
              End With
         Next i
        
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

I've assumed that your data starts in row2 with headings in row1.
I've also assumed that the criteria for patients who have passed screening tests to simply be "Passed" with details going to a sheet named "Passed".

You'll note that the above code is somewhat different to the one that you already have. It uses an array and the Autofilter which will make it much more efficient and faster on large data sets.

I've attached a sample file at the following link to show you how the code works:-

https://wetransfer.com/downloads/efe974a97408fe59b425bab7d52b26f520211008052121/1ef063

Click on the "RUN" button to see it work. You'll note that I have trimmed the sample file down to thirteen columns with the criteria in Column M but the code allows for your actual criteria column AH(34) so it should work as required. Please test the code in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.

Code to move rows into another sheet based on certain values

1 reply

Subscribe To Our Newsletter!