Option Explicit
Sub FilterData()
'DMT32 Dec 2016
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 Prefix As Boolean
'master sheet
Set ws1Master = ActiveSheet
'select the Column you are filtering
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
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
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 FilterCol
.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
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
'filter by prefix chars only
Prefix = FilterByPrefix(sh:=wsFilter)
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
wsFilter.Range("B2").Value = FilterRange.Value
'get sheet name
SheetName = IIf(Prefix, Left(FilterRange.Value, Len(FilterRange.Value) - 1), Left(FilterRange.Value, 31))
'check if Filter sheet exists
On Error Resume Next
Set wsNew = Worksheets(SheetName)
If wsNew Is Nothing Then
'add new sheet
Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
wsNew.Name = SheetName
Err.Clear
Else
'clear existing data
wsNew.UsedRange.Clear
End If
On Error GoTo progend
'copy filtered data
Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
'fit data to columns
wsNew.UsedRange.Columns.AutoFit
End If
'clear from memory
Set wsNew = Nothing
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub
Function FilterByPrefix(ByVal sh As Object) As Boolean
'DMT32 Dec 2016
Dim i As Integer
Dim msg As VbMsgBoxResult
Dim LastRow As Long
msg = MsgBox("Are You Filtering By Prefix?", 292, "Prefix Filter")
If msg = 7 Then Exit Function
LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
With sh.Cells(i, 1)
.Value = Left(.Value, GetPrefix(.Value))
'add wild card
If Len(.Value) > 0 Then .Value = .Value & "*"
End With
Next i
'xl2007 >
sh.Range("A1:A" & LastRow).RemoveDuplicates Columns:=1, Header:=xlNo
FilterByPrefix = True
End Function
Public Function GetPrefix(ByVal Value As String) As Integer
'DMT32 Dec 2016
'locate Pos of Numeric Value
For GetPrefix = 1 To Len(Value)
If Mid(Value, GetPrefix, 1) Like "#" Then GetPrefix = GetPrefix - 1: Exit Function
Next
End Function
