search specific text and copy to another sheet

[koi]

Hi there,

i have this code below that works just fine by using autofilter.selection, problem is when it filter and not find the word "old", it still copy first non blank cell there.

can we add like if not find "old" in auto filter then just skip to next ?

thanks all for the help

Sub rec()
Sheets("1").Select
  Range("B1").Select
  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$E$4").AutoFilter Field:=5, Criteria1:="old"
  Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp).Offset(1, 3))
  Rng.SpecialCells(xlCellTypeConstants).Copy
  sheets("summary").Select
  Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
  Application.CutCopyMode = False
  Sheets("1").Select
  Selection.AutoFilter
Sheets("2").Select
  Range("B1").Select
  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$E$4").AutoFilter Field:=5, Criteria1:="old"
  Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp).Offset(1, 3))
  Rng.SpecialCells(xlCellTypeConstants).Copy
  sheets("summary").Select
  Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
  Application.CutCopyMode = False
  Sheets("2").Select
  Selection.AutoFilter
Sheets("3").Select
  Range("B1").Select
  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$E$4").AutoFilter Field:=5, Criteria1:="old"
  Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp).Offset(1, 3))
  Rng.SpecialCells(xlCellTypeConstants).Copy
  sheets("summary").Select
  Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
  Application.CutCopyMode = False
  Sheets("3").Select
  Selection.AutoFilter
sheets("summary").Select
End Sub

 

[Luke M]

This should do what you want.

Sub rec2()
Dim ws As Worksheet
Dim copyRange As Range
Const myCrit As String = "old"

Application.ScreenUpdating = False
'We'll use a loop so we don't have to repeat our code
For Each ws In Worksheets(Array("1", "2", "3"))
    'Reset our variable
    Set copyRange = Nothing
    'Filter the range
    ws.Range("A1:E4").AutoFilter field:=5, Criteria1:=myCrit
   
    'In case no visible cells
    On Error Resume Next
    Set copyRange = ws.Range("A2:E4").SpecialCells(xlCellTypeVisible)
    Set copyRange = copyRange.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
   
    'Check if there were any cells
    If Not copyRange Is Nothing Then
        copyRange.Copy
        Worksheets("Summary").Range("B65536").End(xlUp).Offset(1, 0). _
            PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    End If
    ws.AutoFilterMode = False
Next ws
Worksheets("Summary").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[koi]

hi Luke,

thanks for replying, and I got error on below code "the command cannot be use in multiple selection"
could it be because you selected 3 sheet as an array before? how if we only want to copy from sheet1 for example?

'Check if there were any cells
If Not copyRange Is Nothing Then
copyRange.Copy

 

[Luke M]

No, the array is not the problem. If you only want to look at sheet 1, you would only list sheet 1 in list at top.
The error message is indicating a problem with discontinuous ranges. I noticed that you specified to only copy cells with constants. Is it possible that in a specific column, one row has a constant and the other has a formula?

 

[koi]

hi Luke,

thanks it is working now, one more question..

if i need to cut those row if they find "old" in it, and delete the row up,

what should i do?

 

[koi]

nevermind luke, i got it, thanks