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

Question

I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.

Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:

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

Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.

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

Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps .