How do I cut and paste a range of cells if criteria met in Excel VBA

Question

I am currently using the following code to cut and paste an entire row from one sheet to another based upon a cell meeting the criteria:

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long

    I = Worksheets("Work Split").UsedRange.Rows.Count
    J = Worksheets("Allocation").UsedRange.Rows.Count
    If J = 1 Then
      If Application.WorksheetFunction.CountA(Worksheets("Allocation").UsedRange) = 0 Then J = 0
      End If

      Set xRg = Worksheets("Work Split").Range("D1:D" & I)
      On Error Resume Next
      Application.ScreenUpdating = False
      For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "allocate" Then
          xRg(K).EntireRow.Copy Destination:=Worksheets("Allocation").Range("A" & J + 1)
          xRg(K).EntireRow.Delete

          If CStr(xRg(K).Value) = "Allocate" Then
            K = K - 1
          End If

          J = J + 1
        End If
      Next
    Application.ScreenUpdating = True

However, this moves the whole row, what do I need to change to move only cells A:H if the criteria is met?

Also, using the above code pastes the data into the next row of cells in the target sheet that have never been used, even if they are currently blank, anyone know why and how to paste in the first available row?

Answer 1

'Cut' (Copy & Delete) Criteria Rows

Option Explicit

Sub MyCode()
    
    Const sName As String = "Work Split"
    Const sfRow As Long = 1 ' This should be 2 if you have headers!?
    Const sCopyCols As String = "A:H"
    Const sCritCol As String = "D"
    Const sCriteria As String = "allocate"
    
    Const dName As String = "Allocation"
    Const dCol As String = "A"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
     
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.UsedRange.Rows.Count
    Dim scrg As Range: Set scrg = sws.Columns(sCopyCols)
    
    Dim srg As Range
    Dim r As Long
    Dim cString As String
    For r = sfRow To slRow
        cString = CStr(sws.Cells(r, sCritCol).Value)
        If StrComp(cString, sCriteria, vbTextCompare) = 0 Then
            If srg Is Nothing Then
                Set srg = scrg.Rows(r)
            Else
                Set srg = Union(srg, scrg.Rows(r))
            End If
        End If
    Next r
    
    If srg Is Nothing Then Exit Sub
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.UsedRange.Rows.Count
    Dim dCell As Range
    Set dCell = dws.Cells(dlRow, dCol).Offset(1)
    
    ' If you really want to write to the first row if it's empty:
    If dlRow = 1 Then
        If Application.CountA(dCell.Resize(, scrg.Columns.Count)) = 0 Then
            Set dCell = dCell.Offset(-1)
        End If
    End If
    
    ' Copy & Delete
    Application.ScreenUpdating = False
    srg.Copy dCell ' copy in one go
    srg.EntireRow.Delete ' delete in one go
    Application.ScreenUpdating = True

End Sub


Sub YourCode()
    ' Use 'Option Explicit', which will force you to declare all variables.
    ' Indent your code properly.
    
    ' Use constants:
    'Const Criteria As String = "allocate"
    'Const cols As String = "A:H"
    
    ' Use more meaningful variable names,
    ' e.g. srg (Source Range), dCell (Destination Cell Range)
    Dim xRg As Range ' srg
    Dim xCell As Range ' dCell
    Dim i As Long ' srCount
    Dim J As Long ' drCount
    Dim K As Long ' was not declared
     
    ' The worksheets are unqualified i.e. it is unclear on which workbook
    ' they reside:
    'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
     
    ' You don't want to repeat 'Worksheets("Allocation")', so use a variable:
    'Dim sws As Worksheet: Set sws = wb.Worksheets("Split")
    'Dim dws As Worksheet: Set dws = wb.Worksheets("Allocation")
    i = Worksheets("Work Split").UsedRange.Rows.Count
    J = Worksheets("Allocation").UsedRange.Rows.Count
    If J = 1 Then
        If Application.WorksheetFunction.CountA( _
            Worksheets("Allocation").UsedRange) = 0 Then J = 0
    End If
    
    Set xRg = Worksheets("Work Split").Range("D1:D" & i)
    
    ' Never ever use this before you fully understand what it does.
    ' Google it, and read what Chip Pearson writes about it.
    'On Error Resume Next
    ' A rule of thumb is to never use it without the closing 'On Error GoTo 0'.
    
    Application.ScreenUpdating = False
    ' Introducing 'K' is confusing because you can just reuse the 'I':
    'For I = 1 To xRg.Count ' in this case even 'For I = 1 to I' works ('D1').
    For K = 1 To xRg.Count
        ' You have to do better if you want to allow 'allocate' and 'AlOcAtE':
        'If StrComp(CStr(xRg(K).Value), "allocate", vbTextCompare) = 0 Then
        If CStr(xRg(K).Value) = "allocate" Then
            xRg(K).EntireRow.Copy Worksheets("Allocation").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            ' Using 'Union' will get rid of the following complications.
            ' Again:
            'If StrComp(CStr(xRg(K).Value), "allocate", vbTextCompare) = 0 Then
            If CStr(xRg(K).Value) = "Allocate" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True

End Sub

Answer 2

Identify the specific Range within the Copy command. The re-worked example below also addresses the comment about using a different (new) worksheet destination.

Comment: It is highly recommended to use meaningful names for variables. Single letter identifiers make reading and understanding code VERY difficult. Also, use spacing and indentation to make code easier to read as well.

    Option Explicit

    Public Sub Test()
        
        'In the example, the target worksheet is "Allocation".  Change the name here to use a different target
        Dim targetWorksheet As Worksheet
        Set targetWorksheet = Worksheets("Allocation")
            
        Dim workSplitWorksheet As Worksheet
        Set workSplitWorksheet = Worksheets("Work Split")
        
        Dim rowsInWorkSplitWorksheet As Long
        rowsInWorkSplitWorksheet = workSplitWorksheet.UsedRange.Rows.Count
        
        Dim workSplitContent As Range
        Set workSplitContent = workSplitWorksheet.Range("D1:D" & rowsInWorkSplitWorksheet)
        
    On Error Resume Next
        Application.ScreenUpdating = False
        
        Dim rangeToCopy As Range
        Dim targetWorksheetNextAvailableRow As Long
        
        Dim workSplitSheetRow As Long
        For workSplitSheetRow = 1 To workSplitContent.Count
            If CStr(workSplitContent(workSplitSheetRow).Value) = "allocate" Then
            
                'Copy a specific Range rather than the whole row
                Set rangeToCopy = workSplitWorksheet.Range("A" & CStr(workSplitSheetRow) & ":H" & CStr(workSplitSheetRow))
                targetWorksheetNextAvailableRow = GetNextAvailableRow(targetWorksheet)
                rangeToCopy.Copy Destination:=targetWorksheet.Range("A" & CStr(targetWorksheetNextAvailableRow))
                
                workSplitContent(workSplitSheetRow).EntireRow.Delete
                
                If CStr(workSplitContent(workSplitSheetRow).Value) = "Allocate" Then
                    workSplitSheetRow = workSplitSheetRow - 1
                End If
            End If
        Next
        
        Application.ScreenUpdating = True

    End Sub

    Private Function GetNextAvailableRow(ByVal worksht As Worksheet) As Long

        GetNextAvailableRow = worksht.UsedRange.Rows.Count
        
        If GetNextAvailableRow = 1 Then
            If Application.WorksheetFunction.CountA(worksht.UsedRange) = 0 Then
                GetNextAvailableRow = 0
            End If
        End If
        GetNextAvailableRow = GetNextAvailableRow + 1
    End Function