Autofilter Macro to Copy to Hidden Sheet

[05Li139]

Morning All,

I've used the below code to create an Autofilter Copy and Paste macro to search a database and copy documents with matching criteria to a new sheet within a workbook.

---

Sub Copy_With_AutoFilter_ToExisting()
Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range


Set My_Range = ActiveSheet.Range("B7", Range("E" & Cells(Rows.Count, "E").End(xlUp).Row))
My_Range.Parent.Select

Set DestSh = Sheets("Sheet2")

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
Sheets("Sheet2").Visible = True
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

My_Range.Parent.AutoFilterMode = False

My_Range.AutoFilter Field:=1, Criteria1:="=United Kingdom"

CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 cells selected:" _
& vbNewLine & "it is not possible to filter a range of this size.", _
vbOKOnly, "Copy to Worksheet"
Else
With My_Range.Parent.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, m.Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Copy
With DestSh.Range("B" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteFormulasAndNumberFormats
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End With
End If

My_Range.Parent.AutoFilterMode = False

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
Sheets(Sheet2).Visible = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

---

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

---

I've hidden all sheets other than the index sheet using the code below;

---

Private Sub Worksheet_Activate()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, "Infopages_001_Index", vbTextCompare) = 0 Then
ws.Visible = False
End If
Next ws
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
With Worksheets(Target.Range.Value)
.Visible = True
.Activate
.Range("A1").Select
End With
End Sub

---

This will allow me to still hyperlink to the destination sheets from the index sheet.

However, when running the main code, the lines highlighted in red that are attempting to unhide "sheet2" whilst the screen updating feature is turned off are causing the code to break.

Can anyone advise on how I might write a workaround into this. I need to keep all of the sheets hidden as in the non-dummy file there are over 100 individual sheets, some of which contain information that absolutely must not be modified by the end user. Also, If anyone can advise on how I would modify the code to paste a smaller number of columns than the range that I am searching (i.e. in the real sheet the search must look for the correct values in fields 26-110, but only the names and tags listed in fields 1-6 are relevant to the end user for the purpose of the database.) so is it possible to write the code to search a much larger range of columns than need to be copied?

If the code from the full sheet would be useful for this part of the question, I can post it in.

Thank you,

L