How to copy and paste rows before deleting them in excel VBA

Question

I am looking to filter out a set of data with the criteria being if column A has over 5 characters in the string delete it.

However, before I delete it, I want to copy these entries to a sheet named "fixed"

The code I have at the moment works for the first entry, but doesn't loop through and I am unsure how to fix that...

Code:

Dim LR As Long, i As Long

LR = Worksheets("Output Sheet").Range("A" & Rows.Count).End(xlUp).Row
                For i = LR To 1 Step -1
                
                    If Len(Range("A" & i).Value) >= 5 Then
                    Rows(i).EntireRow.Cut Worksheets("Fixed").Range("A:D")
                    Rows(i).Delete
                   
                      End If
                   Next i

The data it is copying has 4 columns if that's of any help? I just can't seem to figure out why it doens't look but I am nearly positive it's a simple fix so any pointers would be appreciated.

Answer 1

Backup Data

• This will add a formula ( =LEN(A1) ) to an inserted column range ( E ), to calculate the length of the values of the criteria column ( A ), and filter this range.
• The filtered data ( sdvrg ) will be copied (appended) to another worksheet ( Fixed ) and the filtered data's entire rows will be deleted.
• Finally, the inserted column ( E ) will be deleted.

Option Explicit

Sub BackupData()
    
    Const sName As String = "Output Sheet"
    Const sCols As String = "A:D"
    Const scCol As Long = 1 ' Criteria Column
    Const shRow As Long = 1 ' Header Row
    Const sLenCriteria As String = ">5"
    
    Const dName As String = "Fixed"
    Const dCol As String = "A"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim slRow As Long
    With sws.Columns(sCols).Columns(scCol)
        slRow = .Cells(.Cells.Count).End(xlUp).Row
    End With
    If slRow <= shRow Then Exit Sub ' no data or just headers
    
    Dim srCount As Long: srCount = slRow - shRow + 1
    ' Source Table Range ('strg') (headers)
    Dim strg As Range: Set strg = sws.Rows(shRow).Columns(sCols).Resize(srCount)
    ' Source Data Range ('sdrg') (no headers)
    Dim sdrg As Range: Set sdrg = strg.Resize(srCount - 1).Offset(1)
    Dim scCount As Long: scCount = strg.Columns.Count
    
    Application.ScreenUpdating = False
    
    ' Source Inserted Column Range ('sicrg') (headers)
    Dim sicrg As Range: Set sicrg = strg.Columns(1).Offset(, scCount)
    sicrg.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Set sicrg = sicrg.Offset(, -1) ' account for 'Insert'
    ' The formula is also written to the header row which is irrelevant
    ' to the upcoming 'AutoFilter'.
    sicrg.Formula = "=LEN(" & strg.Cells(1, scCol).Address(0, 0) & ")"
    sicrg.AutoFilter 1, sLenCriteria
    
    ' Source Data Visible Range ('sdvrg') (no headers)
    Dim sdvrg As Range
    On Error Resume Next ' prevent 'No cells found' error.
        Set sdvrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    Dim WasBackedUp As Boolean
    
    If Not sdvrg Is Nothing Then
        
        Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
        If dws.AutoFilterMode Then dws.AutoFilterMode = False
        Dim dfCell As Range
        Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
        
        sdvrg.Copy dfCell
        sdvrg.EntireRow.Delete Shift:=xlShiftUp ' resizes 'sicrg' appropriately
    
        WasBackedUp = True
    
    End If
    
    sicrg.Delete Shift:=xlShiftToLeft
    
    Application.ScreenUpdating = True
    
    If WasBackedUp Then
        MsgBox "Data backed up.", vbInformation
    Else
        MsgBox "No action taken.", vbExclamation
    End If

End Sub