使用 VBA 过滤和移动数据答案

【问题标题】：Filtering and moving data with VBA使用 VBA 过滤和移动数据
【发布时间】：2021-10-12 01:08:33
【问题描述】：

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

准确地说：

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。 “德” 将范围（b2：f2）剪切到下一张

经验。

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

【问题讨论】：

标签： excel vba navbar

【解决方案1】：

如果您需要剪切和粘贴，很好，请注意您需要选择粘贴目标表，然后再次选择源表。但是，如果您只对单元格内容感兴趣，那么仅“传输”值会更简单且（快得多），如下所示。

Private Sub CommandButton1_Click()

Dim rng As Range, cell As Range
Dim TargetRow As Long

Set rng = Range("a2:a100")

    For Each cell In rng
        If cell = "DE" Then
            TargetRow = cell.Row
            Worksheets("Sheet2").Range("B" & TargetRow & ":F" & TargetRow).Value2 = Worksheets("Sheet1").Range("B" & TargetRow & ":F" & TargetRow).Value2
            Worksheets("Sheet1").Range("B" & TargetRow & ":F" & TargetRow).ClearContents
        End If
    Next cell
    
End Sub

【讨论】：

也谢谢你，我是 VBA 编码的新手，这种代码将来也可以使用，非常感谢 :)

【解决方案2】：

剪切标准行 (`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

【讨论】：

嗨。我已经为我的表实现了这段代码，它运行良好，我非常感谢你。 :)

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

剪切标准行 (`For Each...Next`)