Excel Forum

Code: Select all

'Othe code
    ' Loop through each row in the Date sheet and copy rows based on the value in column A
    For i = 2 To lastRowDate
'        If wsDate.Cells(i, 1).Value = cellValue Then
            wsDate.Rows(i).Copy Destination:=wsPaster.Rows(destRow)
            destRow = destRow + 1
'        End If
    Next i
'Other code

Code: Select all

Sub Test0()
    Dim fOne As Range, fStt As Range
    Dim lstC As Range, srRngs As Range
    
    If Not IsNumeric(Worksheets("Paster").Range("B1")) Then
        MsgBox "The value in A1 is not a valid number.", vbExclamation
        Exit Sub
    End If
    
    With Worksheets("Date")
        Set lstC = .Range("b" & .Rows.Count).End(xlUp)
        Set fOne = .Range("a:a").Find(what:=1, LookIn:=xlValues, lookat:=xlPart)
        Set fStt = .Range(fOne, lstC).Find(what:="Subtotal:", LookIn:=xlValues, lookat:=xlPart)
        Set srRngs = .Range(fOne, fStt).Resize(, 6)
    End With
    With Worksheets("Paster")
        .Range("b1").CurrentRegion.Offset(1, 0).ClearContents
        .Range("b2").Resize(srRngs.Rows.Count, srRngs.Columns.Count).Value = srRngs.Value
    End With
End Sub

Code: Select all

Sub Test1()
    Dim ws As Worksheet
    Dim firstAddress As String
    Dim cell As Range, sv As String
    Dim cpRngs As Range

    Set ws = ThisWorkbook.Sheets("Date")
    Set wt = ThisWorkbook.Sheets("Paster")
    
    With wt
        sv = wt.Range("b1").Value
        .UsedRange.Offset(1, 0).ClearContents
    End With
    
    Set cell = ws.Columns("B").Find(What:=sv, LookIn:=xlValues, LookAt:=xlWhole)

    If Not cell Is Nothing Then
        firstAddress = cell.Address
        Do
            With ws
                Set cpRngs = .Range(cell, cell.End(xlDown))
            End With
            With wt
                cpRngs.Resize(, 6).Copy .Range("b" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            Set cell = ws.Columns("B").FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> firstAddress
    End If
End Sub