excel - 使用 VBA 过滤和移动数据

Question

我正在尝试找到一种方法来快速过滤并将单元格范围切割到另一张纸上

准确地说：

Private Sub CommandButton1_Click()

Dim rng As Range, cell As Range

Set rng = Range("a2:a100")

For Each cell In rng

If Sheet1.Range("a2").Offset(1) = "DE" Then
Sheet1.Range("b2:f2").Cut Sheet2.Range("b2:f2")

End If
Next cell
End Sub

我知道此代码仅限于 Cell(A2)。

我需要我的代码通过 Range ("a2:a100") 以及它是否包含值 Exp。“DE”将范围（b2：f2）剪切到下一张纸

经验。

如果单元格a2包含“DE”，则需要剪切范围（“b2：f2”）如果单元格a5包含“DE”，则需要剪切范围（“b5：f5”）exc ...

标签： excelvbanavbar

Answer 1

切割标准行 ( For Each...Next)

• 使用数组或使用AutoFilter肯定会更有效。

Option Explicit

Sub CutCriteriaRows()
    
    Const sCol As String = "A"
    Const sdCols As String = "B:F"
    Const sfRow As Long = 2
    Const sCriteria As String = "DE"
    
    Const dCol As String = "B"
    
    Dim sws As Worksheet: Set sws = Sheet1
    Dim dws As Worksheet: Set dws = Sheet2
    
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    
    Dim scrg As Range
    Dim sCell As Range

    For Each sCell In srg.Cells
        If CStr(sCell) = sCriteria Then
            Set scrg = RefCombinedRange(scrg, sCell)
        End If
    Next sCell
    
    If scrg Is Nothing Then Exit Sub
    
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row
    Dim dfCell As Range: Set dfCell = dws.Cells(dlRow + 1, dCol)
    
    With Intersect(scrg.EntireRow, sws.Columns(sdCols))
        .Copy dfCell
        .EntireRow.Delete
    End With

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function