Code to move rows into another sheet based on certain values

[Solved]
Report
Posts
2
Registration date
Thursday October 7, 2021
Status
Member
Last seen
October 8, 2021
-
Posts
1320
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
October 8, 2021
-
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

    Next

    Application.ScreenUpdating = True

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

1 reply

Posts
1320
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
October 8, 2021
239
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.
1
Thank you

Glad we were able to help! Love us? Write us a review! Rate CCM

CCM 2821 users have said thank you to us this month

Posts
2
Registration date
Thursday October 7, 2021
Status
Member
Last seen
October 8, 2021

Thank you! This works perfectly, and is exactly what I needed. You're the best!
Posts
1320
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
October 8, 2021
239 >
Posts
2
Registration date
Thursday October 7, 2021
Status
Member
Last seen
October 8, 2021

You're welcome jcbbach. I'm glad to have been able to assist and thank you for the kind feed back.

Cheerio,
vcoolio.