How can I copy rows containing specific values into a new sheet in Excel using VBA?

Question

I'm currently working on a code that finds a certain value then copies all of the rows from the original sheet onto the second sheet that contains that specific value. It works except I can only apply it to one text and I need to add 51 special values that need to be copied. I know that's a lot but I'm working with a lot of data. If I need to copy and paste a certain type of code 51 times to make it works ill do that however I cant figure out how to make it so this code looks up more values.

Also, when the code runs, the sheet its being pasted to has a header but the rows get pasted in the third row down not the second. not sure why it left a blank row right underneath the headers. And is it possible for the rows that get copied are then deleted from sheet 1(where its getting copied from)?

This is the code I'm working with, the portion that goes If CStr(DataRg(I).Value) = "Special Value" Then i tried to duplicate and use different values but it didnt work.

Sub NYC()

Dim DataRg As Range
Dim DataCell As Range
Dim P As Long
Dim J As Long
Dim I As Long


P = Worksheets("DLS-Route").UsedRange.Rows.Count
Q = Worksheets("NYC Source").UsedRange.Rows.Count


If I = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("NYC Source").UsedRange) = 0 Then Q = 0
End If


Set DataRg = Worksheets("DLS-Route").Range("B1:B" & P)
On Error Resume Next
Application.ScreenUpdating = False


For I = 1 To DataRg.Count
    If CStr(DataRg(I).Value) = "Special Value" Then
        DataRg(I).EntireRow.Copy Destination:=Worksheets("NYC Source").Range("A" & Q + 1)
        Q = Q + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

"it didn't work" isn't very useful. Can you describe the problem a bit better? I would also comment out `On Error Resume Next` and it will hide problems in the code — cybernetic.nomad, May 23 '23 at 20:20
Yea you're right, sorry about that. When I try to run the code I receive error message "Compile error: Next without For". — Giovanni03, May 23 '23 at 20:31
You're right, just got this to work with a different code, similar but slightly different. I appreciate you trying to help. — Giovanni03, May 23 '23 at 22:45
The code as you have it on here shouldn't give that error and if your dataset is as big as you claim, you shouldn't check cell per cell like that, try working with arrays. As for your multiple special values, have those in (a range and then in) an array and loop through them with [Application.Match](https://stackoverflow.com/a/75627716/19353309) or loop through DataRg (that you throw in an array) and loop on those while checking if they're in your special values array [with something like this](https://stackoverflow.com/a/10952705/19353309) — Notus_Panda, May 23 '23 at 22:53

score 1 · Accepted Answer · answered May 24 '23 at 10:00

try

Sub MoveRowsBasedOnValue()
    Dim wsRoute As Worksheet
    Dim wsSource As Worksheet
    Dim lastRow As Long, i
    Dim nextRow As Long
    Dim cell As Range
    Dim specialValue As String
    Dim myarr
    
    'modify/add values to search
    myarr = Array("sv1", _
                               "sv2", _
                               "sv3")
                                   
    Set wsRoute = Worksheets("DLS-Route")
    Set wsSource = Worksheets("NYC Source")
    
    lastRow = wsRoute.Cells(wsRoute.Rows.Count, "B").End(xlUp).Row
    nextRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row + 1
    
    For i = lastRow To 1 Step -1
        ' Check if the value is in myarr list
        If IsInArray(wsRoute.Range("B" & i), myarr) Then
            wsRoute.Rows(i).EntireRow.Cut wsSource.Rows(nextRow)
            nextRow = nextRow + 1
        End If
    Next i
    
    'delete blank rows
    Dim rng As Range
    Dim dlRow As Long

    With wsRoute
        dlRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A1:A" & dlRow)
    End With

    On Error Resume Next
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End Sub

Function IsInArray(ByVal value As String, ByVal arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If StrComp(element, value, vbTextCompare) = 0 Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

How can I copy rows containing specific values into a new sheet in Excel using VBA?

1 Answers1