如何在 excel VBA 中删除行之前复制和粘贴行

Question

我想过滤掉一组数据，条件是如果 A 列在字符串中有超过 5 个字符，则将其删除。

但是，在我删除它之前，我想将这些条目复制到一个名为“fixed”的sheet

我目前的代码适用于第一个条目，但没有循环，我不确定如何解决这个问题...

代码：

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

它正在复制的数据有 4 列，是否有帮助？我似乎无法弄清楚为什么它看起来不对，但我几乎肯定它是一个简单的修复程序，因此我们将不胜感激。

Dim  f As Long

Set Rng = Worksheets("Black List").Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
With Worksheets("Output Sheet")
 
    Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For f = Lastrow To 1 Step -1
             If Not IsError(Application.Match(.Range("A" & f).Value, Rng, 0)) Then
            .Rows(f).Delete
        End If
    Next f
End With
Application.ScreenUpdating = True

Answer 1

备份数据

这会将公式 (=LEN(A1)) 添加到插入的列范围 (E)，以计算条件列 (A) 的值的长度，以及过滤此范围。
过滤后的数据 (sdvrg) 将被复制（追加）到另一个工作表 (Fixed) 并且过滤后的数据的整行将被删除。
最后，插入的列（E）将被删除。

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

如何在 excel VBA 中删除行之前复制和粘贴行

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

excel

vba

autofilter

excel-formula

备份数据