Pfthb

I am trying to auto-copy specific rows in a Table from one worksheet to a separate worksheet. Below is my code. The first half hides/unhides specific Columns based on the value entered into Column B. The second half aims to copy across specific rows when a designated value is entered into Column B.

I can get this working when the Master worksheet is a Range but not a Table. This is my attempt when formatted as a Table.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B:B")) Is Nothing Then
 On Error GoTo safe_exit
 Application.EnableEvents = False
 '****************
 FilterAndCopy
 '****************
 Dim t As Range
 For Each t In Intersect(Target, Range("B:B"))
 Select Case (t.Value)
 Case "Change of Numbers"
 Columns("B:BP").EntireColumn.Hidden = False
 Columns("H:BL").EntireColumn.Hidden = True
 'do nothing
 End Select
 Next t

End If

safe_exit:
 Application.EnableEvents = True
End Sub

'****************

Sub FilterAndCopy()
 Dim rng As Range, sht1 As Worksheet, sht2 As Worksheet

 Set sht1 = Worksheets("MASTER")
 Set sht2 = Worksheets("CON")

 sht2.ListObjects(1).DataBodyRange.ClearContents

 With Intersect(sht1.Columns("B:BP"), sht1.ListObjects(1).DataBodyRange)
 .Cells.EntireColumn.Hidden = False ' unhide columns
 If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False

 Dim rngToCopy As Range
 .AutoFilter field:=1, Criteria1:="Change of Numbers"
 Set rngToCopy = Intersect(.SpecialCells(xlCellTypeVisible), sht1.Range("A:F, BL:BO"))
 Debug.Print rngToCopy.Address
 rngToCopy.Copy Destination:=sht2.Cells(4, "B")
 .Parent.AutoFilterMode = False

 .Range("H:BK").EntireColumn.Hidden = True ' hide columns
 End With
End Sub

The error is:

Subscript out of range