Option Explicit
Sub FilterDataPlacement()
Windows("data.xlsm").Activate
Columns("B:B").Select
Selection.Replace What:="/", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
Dim SheetName As String, msg As String
Dim location As String
Set ws1Master = ActiveSheet
top:
On Error Resume Next
Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
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
On Error GoTo progend
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:=""
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 700000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
.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
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
If Len(FilterRange.Value) > 0 Then
wsFilter.Range("B2").Value = FilterRange.Value
SheetName = Trim(Left(FilterRange.Value, 31))
On Error Resume Next
Set wsNew = Worksheets(SheetName)
If wsNew Is Nothing Then
Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
wsNew.Name = SheetName
Else
wsNew.UsedRange.ClearContents
End If
On Error GoTo progend
Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
End If
wsNew.UsedRange.Columns.AutoFit
Set wsNew = Nothing
Next
.Select
End With
progend:
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub