Loop

[Brian]

I have this macro set to a button and would like to be able to loop it so I
only have to click it once to move all the rows with the term "Completed" in
the specified cell.


Sub Active()
Application.ScreenUpdating = False

Columns("H:H").Select
Cells.Find(What:="completed", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Dim sourceRange As Range
Dim destrange As Range
Dim Lr As Long
Lr = LastRow(Sheets("Completed")) + 1
Set sourceRange = ActiveCell.EntireRow
Set destrange = Sheets("Completed").Rows(Lr)
sourceRange.Copy destrange
sourceRange.EntireRow.Delete

Sheets("Active").Select
Range("A2").Select

Application.ScreenUpdating = True

End Sub

Any help would be appreciated. Thank you

 

[Per Jessen]

Hi Brian

Try this:

Sub Active()
Dim SourceRange As Range
Dim DestRange As Range
Dim Lr As Long
Application.ScreenUpdating = False

Do
Set f = Columns("H:H").Find(What:="completed", After:=Range("H1"),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If f Is Nothing Then Exit Do
Lr = LastRow(Sheets("Completed")) + 1
Set SourceRange = f.EntireRow
Set DestRange = Sheets("Completed").Rows(Lr)
SourceRange.Copy DestRange
SourceRange.Delete ' EntireRow is not needed here as sourceRange is set
as entireRow
Loop

Sheets("Active").Select
Range("A2").Select

Application.ScreenUpdating = True

End Sub

Regards,
Per

 

[Don Guillett]

Try

Sub filterandmove()
dlr = Sheets("sheet26").Cells(Rows.Count, "a").End(xlUp).Row + 1
mc = 1 "A"
lr = Cells(Rows.Count, mc).End(xlUp).Row
With Range(Cells(1, mc), Cells(lr, mc))
..AutoFilter Field:=1, Criteria1:="cc"
..SpecialCells(xlVisible).EntireRow.Copy _
Sheets("sheet26").Rows(dlr)
..Resize(1).SpecialCells(xlVisible).EntireRow.Delete
..AutoFilter
End With
End Sub