loop: copy if

[mohamadba91]

hi
i want a code which check second colulm and if to right charcter was 01 then copy entire row to another sheet
for example if b2=9164801 then copy row 2 in sheet2 and do it again until the last row
can anybody help me on it
i would appreciate you

 

[JoeMo]

Does this do what you want? Change destination sheet name to suit - assumes destination sheet already exists.

Sub CopyIf01()
Dim c As Range, NxRw As Long
Application.ScreenUpdating = False
For Each c In Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    If c.Value Like "*01" Then
       With Sheets("Sheet3")
            If IsEmpty(.Range("A1")) Then
                NxRw = 1
            Else
                NxRw = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            End If
        End With
        Intersect(c.EntireRow, ActiveSheet.UsedRange).Copy Destination:=Sheets("Sheet3").Cells(NxRw, "A")
    End If
Next c
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

 

[Mentor82]

Hi,
Check this out.

Sub CopyRows()
Dim ws1 as worksheet
Dim ws2 ad worksheet
Dim i&
Dim counter&

Set ws1=worksheets(1)
Set ws2=worksheets(2)
i=2
With ws1
Do while .cells(i, "B")<>""
    If cstr(right(.cells(i,"B"),2))="01" then
         counter=counter+1
        .cells(i,"B").EntireRow.copy ws2.cells(counter,"A")
    End if
    i=i+1
Loop
end with

Set ws1=nothing
Set ws2= nothing
End sub