如何使用 VBA 将遵循特定字符串的动态数据范围从一张纸复制到另一张纸？

Question

我正在尝试在 Sheet1 列 a 中搜索字符串“测试测试”（是的，事先使用空格），然后复制包含该字符串的行下方的所有行，直到找到一个空白行，然后我想将此选定范围粘贴到 A 列中Sheet2 上的第 1 行。 接下来，我想搜索字符串“CASH”（再次是，预先使用空格）并且我只想复制包含要粘贴的行的行，该行粘贴到粘贴的第一个范围的最后一行下方的 2 行。

这是我到目前为止所拥有的，它不起作用......我什至没有解决找到第二个字符串的第二个组成部分，因为我无法得到第一个......请协助，不知道为什么这不起作用：

Sub Test()

Dim StringToFind As String

Dim i As Range

Dim cell As Range

StringToFind = "   Testing Test"

With Worksheets("Sheet1")

Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
                            MatchCase:=False, searchformat:=False)
                            
If Not cell Is Nothing Then

For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))

If IsNumeric(i.Value) Then

If i.Value > 0 Then

i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial

End If

End If

Next i


Else


End If

End With

                            

End Sub

Answer 1

你的问题缺乏一点细节。 但是，下面的代码将为您指明正确的方向。 如果您需要帮助来管理它，请询问。

Sub FindAndCopy()
    ' 221
    
    Dim WsS         As Worksheet            ' Source
    Dim WsT         As Worksheet            ' Target
    Dim Caps()      As String               ' captions to find
    Dim Fnd         As Range                ' found caption
    Dim Tgt         As Range                ' Target
    Dim Arr         As Variant              ' Value of Fnd
    Dim f           As Integer              ' loop counter: Caps
    
    With ThisWorkbook
        Set WsS = .Worksheets("Sheet1")     ' change to suit
        Set WsT = .Worksheets("Sheet2")     ' change to suit
    End With
    Caps = Split("Testing Test,CASH", ",")  ' extend to suit
    For f = 0 To UBound(Caps)
        Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
                                   MatchCase:=False, SearchFormat:=False)
        If Fnd Is Nothing Then Exit For
        
        Set Fnd = Fnd.Offset(1)
        If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
        Arr = Fnd.Value                     ' copies Values, not Formulas
        
        With WsT
            Set Tgt = .Cells(1, 1)
            If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
            If VarType(Arr) >= vbArray Then
                Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
            Else
                Tgt.Value = Arr
            End If
        End With
    Next f
End Sub

请注意，我放弃了搜索条件中的前导空格，转而在Find function 中查找部分匹配项。 这样，有多少空格并不重要，但如果有多个匹配项，可能会引起混乱。 在这种情况下，您可以通过修改Caps数组来恢复空白。