Macro Help

[Simon Dowse]

Hi,

Using the below macro I can copy the contents of 1 sheet
to another where the contents of row 12 is red. As I have
more that 1 sheet in my spreadsheet, how do I extend this
so that it also copied from the other sheets?

Sub FilterTest()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lngSourceLastRow As Long, lngTargetLastRow As Long
Dim rngSource As Range

Set wsSource = Worksheets("Storage Consolidation")
Set wsTarget = Worksheets("Risk Board Report")

lngSourceLastRow = wsSource.Range("B65536").End
(xlUp).Row
lngTargetLastRow = wsTarget.Range("A65536").End
(xlUp).Row

Set rngSource = wsSource.Range("A2" &
lngSourceLastRow)
wsSource.Range("A1").AutoFilter Field:=12,
Criteria1:="Red"
On Error Resume Next
Set rngSource = rngSource.SpecialCells
(xlCellTypeVisible)
If rngSource Is Nothing Then Exit Sub ' no
visible cells
rngSource.Copy wsTarget.Range("A" & lngTargetLastRow +
1)
wsSource.Range("A1").AutoFilter
End Sub

Any help would be greatly appreciated.

Regards,
Simon

 

[Tom Ogilvy]

Sub FilterTest()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lngSourceLastRow As Long, lngTargetLastRow As Long
Dim rngSource As Range

Set wsTarget = Worksheets("Risk Board Report")

for each wsSource in Worksheets
if wsSource.name <> wsTarget.name then
lngSourceLastRow = wsSource.Range("B65536").End(xlUp).Row
lngTargetLastRow = wsTarget.Range("A65536").End(xlUp).Row

Set rngSource = wsSource.Range("A2" & lngSourceLastRow)
wsSource.Range("A1").AutoFilter Field:=12, Criteria1:="Red"
On Error Resume Next
Set rngSource = rngSource.SpecialCells(xlCellTypeVisible)
If rngSource Is Nothing Then Exit Sub ' no visible cells
rngSource.Copy wsTarget.Range("A" & lngTargetLastRow + 1)
wsSource.Range("A1").AutoFilter
Next wsSource
End Sub

 

[Guest]

Many thanks!

I've input this as below and when I go to 'Compile VBA
Project' I get an error message that says:

Compile Error:
Next without For

Any ideas?

 

[Tom Ogilvy]

Sub FilterTest()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lngSourceLastRow As Long, lngTargetLastRow As Long
Dim rngSource As Range

Set wsTarget = Worksheets("Risk Board Report")

for each wsSource in Worksheets
if wsSource.name <> wsTarget.name then
lngSourceLastRow = wsSource.Range("B65536").End(xlUp).Row
lngTargetLastRow = wsTarget.Range("A65536").End(xlUp).Row

Set rngSource = wsSource.Range("A2" & lngSourceLastRow)
wsSource.Range("A1").AutoFilter Field:=12, Criteria1:="Red"
On Error Resume Next
Set rngSource = rngSource.SpecialCells(xlCellTypeVisible)
If rngSource Is Nothing Then Exit Sub ' no visible cells
rngSource.Copy wsTarget.Range("A" & lngTargetLastRow + 1)
wsSource.Range("A1").AutoFilter
End if '<=== added line
Next wsSource
End Sub

 

[Guest]

Ok, that compiled.

Now when I try and run the macro it brings up a new
message:

Run-time error '1004':
AutoFilter method of range class failed

Any ideas?

 

[Tom Ogilvy]

That would indicate that you don't have the data in the worksheet to support
putting in an autofilter that would have 12 columns (so you can filter on
the 12th column). At least such data doesn't start in column A.

You could check whether there is any point to it:

Sub FilterTest()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lngSourceLastRow As Long, lngTargetLastRow As Long
Dim rngSource As Range, rng as range, rng1 as Range

Set wsTarget = Worksheets("Risk Board Report")

for each wsSource in Worksheets
if wsSource.name <> wsTarget.name then
lngSourceLastRow = wsSource.Range("B65536").End(xlUp).Row
lngTargetLastRow = wsTarget.Range("A65536").End(xlUp).Row

Set rngSource = wsSource.Range("A2" & lngSourceLastRow)
set rng = Intersect(rngSource, wsSource.Columns(12))
set rng1 = Nothing
set rng1 = rng.Find("Red")
if not rng1 is nothing then
wsSource.Range("A1").AutoFilter Field:=12, Criteria1:="Red"
On Error Resume Next
Set rngSource = rngSource.SpecialCells(xlCellTypeVisible)
If rngSource Is Nothing Then Exit Sub ' no visible cells
rngSource.Copy wsTarget.Range("A" & lngTargetLastRow + 1)
wsSource.Range("A1").AutoFilter
Else
msgbox "No Reds in sheet " & wsSource
End if
End if '<=== added line
Next wsSource
End Sub