Sub blah()
Dim strAFilterRng As String ' Autofilter range
Dim varFilterCache() ' Autofilter cache
Dim wksAF As Worksheet
' [set up code]
Application.ScreenUpdating = False
Set wksAF = Worksheets("MASTER")
SaveFilters wksAF, strAFilterRng, varFilterCache
Set SourceList = wksAF.Range("A1:XZ1000")
For Each Sht In Sheets(Array("Area1g", "Area2k", "Area3w", "Area4a"))
With Sht
.UsedRange.Clear
.Cells.FormatConditions.Delete
On Error Resume Next: .Names("Extract").Delete: On Error GoTo 0
.Range("AAA1:AAA2") = Application.Transpose(Array("Area", "*" & Sht.Name & "*"))
SourceList.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("AAA1:AAA2"), CopyToRange:=.Range("A1"), Unique:=False
' Application.Goto .UsedRange.Offset(1)
.Range("A1").AutoFilter
.Cells.EntireColumn.AutoFit
For Each colm In .UsedRange.Offset(1).Resize(, 703).Columns ' limited to 170 columns, you can adjust.
If Application.WorksheetFunction.CountBlank(colm) = colm.Rows.Count Then colm.EntireColumn.Hidden = True Else colm.EntireColumn.Hidden = False
Next colm
Set uuu = .Range("A1").CurrentRegion
Set uuu = uuu.Offset(1).Resize(uuu.Rows.Count - 1)
uuu.FormatConditions.Add(Type:=xlBlanksCondition).Interior.ColorIndex = 1
With uuu.FormatConditions.Add(Type:=xlExpression, Formula1:="=ISEVEN(ROW())").Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599963377788629
End With
End With
Next Sht
' Restore original autofilter if present ..
RestoreFilters wksAF, strAFilterRng, varFilterCache
Application.ScreenUpdating = True
End Sub
' Usage example:
' Dim strAFilterRng As String ' Autofilter range
' Dim varFilterCache() ' Autofilter cache
' ' [set up code]
' Set wksAF = Worksheets("Configuration")
'
' ' Check for autofilter, turn off if active..
' SaveFilters wksAF, strAFilterRng, varFilterCache
' [code with filter off]
' [set up special auto-filter if required]
' [code with filter on as applicable]
' ' Restore original autofilter if present ..
' RestoreFilters wksAF, strAFilterRng, varFilterCache
'~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Sub: SaveFilters
' Purpose: Save filter on worksheet
' Returns: wks.AutoFilterMode when function entered
'
' Arguments:
' [Name] [Type] [Description]
' wks I/P Worksheet that filter may reside on
' FilterRange O/P Range on which filter is applied as string; "" if no filter
' FilterCache O/P Variant dynamic array in which to save filter
'
' Author: Based on MS Excel AutoFilter Object help file
'
' Modifications:
' 2006/12/11 Phil Spencer: Adapted as general purpose routine
' 2007/03/23 PJS: Now turns off .AutoFilterMode
' 2013/03/13 PJS: Initial mods for XL14, which has more operators
'
' Comments:
'----------------------------
Function SaveFilters(wks As Worksheet, FilterRange As String, FilterCache()) As Boolean
Dim ii As Long
FilterRange = "" ' Alternative signal for no autofilter active
SaveFilters = wks.AutoFilterMode
If SaveFilters Then
With wks.AutoFilter
FilterRange = .Range.Address
With .Filters
ReDim FilterCache(1 To .Count, 1 To 3)
For ii = 1 To .Count
With .Item(ii)
If .On Then
#If False Then ' XL11 code
FilterCache(ii, 1) = .Criteria1
If .Operator Then
FilterCache(ii, 2) = .Operator
FilterCache(ii, 3) = .Criteria2
End If
#Else ' first pass XL14
Select Case .Operator
Case 1, 2 'xlAnd, xlOr
FilterCache(ii, 1) = .Criteria1
FilterCache(ii, 2) = .Operator
FilterCache(ii, 3) = .Criteria2
Case 0, 3 To 7 ' no operator, xlTop10Items, xlBottom10Items, xlTop10Percent, xlBottom10Percent, xlFilterValues
FilterCache(ii, 1) = .Criteria1
FilterCache(ii, 2) = .Operator
Case Else ' These are not correctly restored; there's someting in Criteria1 but can't save it.
FilterCache(ii, 2) = .Operator
End Select
#End If
End If
End With ' .Item(ii)
Next
End With ' .Filters
End With ' wks.AutoFilter
wks.AutoFilterMode = False ' turn off filter
End If ' wks.AutoFilterMode
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Sub: RestoreFilters
' Purpose: Restore filter on worksheet
' Arguments:
' [Name] [Type] [Description]
' wks I/P Worksheet that filter resides on
' FilterRange I/P Range on which filter is applied
' FilterCache I/P Variant dynamic array containing saved filter
'
' Author: Based on MS Excel AutoFilter Object help file
'
' Modifications:
' 2006/12/11 Phil Spencer: Adapted as general purpose routine
' 2013/03/13 PJS: Initial mods for XL14, which has more operators
'
' Comments:
'----------------------------
Sub RestoreFilters(wks As Worksheet, FilterRange As String, FilterCache())
Dim col As Long
wks.AutoFilterMode = False ' turn off any existing auto-filter
If FilterRange <> "" Then
wks.Range(FilterRange).AutoFilter ' Turn on the autofilter
For col = 1 To UBound(FilterCache(), 1)
#If False Then ' XL11
If Not IsEmpty(FilterCache(col, 1)) Then
If FilterCache(col, 2) Then
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1), Operator:=FilterCache(col, 2), Criteria2:=FilterCache(col, 3)
Else
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1)
End If
End If
#Else
If Not IsEmpty(FilterCache(col, 2)) Then
Select Case FilterCache(col, 2)
Case 0 ' no operator
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1) ' Do NOT reload 'Operator'
Case 1, 2 'xlAnd, xlOr
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1), Operator:=FilterCache(col, 2), Criteria2:=FilterCache(col, 3)
Case 3 To 6 ' xlTop10Items, xlBottom10Items, xlTop10Percent, xlBottom10Percent
#If True Then
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1) ' Do NOT reload 'Operator' , it doesn't work
' wks.AutoFilter.Filters.Item(col).Operator = FilterCache(col, 2)
#Else ' Trying to restore Operator as well as Criteria ..
' Including the 'Operator:=' arguement leads to error.
' Criteria1 is expressed as if for a FALSE .Operator
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1), Operator:=FilterCache(col, 2)
#End If
Case 7 'xlFilterValues
wks.Range(FilterRange).AutoFilter field:=col, Criteria1:=FilterCache(col, 1), Operator:=FilterCache(col, 2)
#If False Then ' Switch on filters on cell formats
' These statements restore the filter, but cannot reset the pass Criteria, so the filter hides all data.
' Leave it off instead.
Case Else ' (Various filters on data format)
wks.Range(FilterRange).AutoFilter field:=col, Operator:=FilterCache(col, 2)
#End If ' Switch on filters on cell formats
End Select
End If
#End If ' XL11 / XL14
Next col
End If
End Sub