Option Explicit
Sub FilterData()
'DMT32 updated June 2020
Dim ws1Master As Worksheet, wsName As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range
Dim rowcount As Long, FilterRow As Long, colcount As Long, FilterCol As Long
Dim SheetName As String, msg As String
'master sheet
Set ws1Master = ActiveSheet
'select the Column filtering
top:
On Error Resume Next
Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
On Error GoTo progend
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
FilterRow = objRange.Row
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
'add password if needed
.Unprotect Password:=""
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
'extract Unique values from selected column
.Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'apply criteria field heading
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
'create criteria for exact match
wsFilter.Range("B2").Formula = "=" & """=" & FilterRange.Value & """"
'ensure tab name limit not exceeded
SheetName = Trim(Left(FilterRange.Value, 31))
'check if sheet exists
If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
End If
'set wsname object variable
Set wsName = Worksheets(SheetName)
'clear existing data
wsName.UsedRange.ClearContents
'apply filter
Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=wsName.Range("A1"), Unique:=False
End If
'size column widths to match master
'NB - slows code down a little
Datarng.Rows(1).Copy
wsName.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths
Set wsName = Nothing
'clear clipboard
Application.CutCopyMode = False
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub