'This will filter multiple selected items in a single column that you select
'Copy a cell with several items separated by a comma or (comma space)
'You may run this again with a different set of criteria on the same or a different column
'Autofilter will be activated if off
'Filter Criteria requires the number formatting to be correct with all commas and dollar signs
'This assumes the number format is the same for the whole column
'This will add the positive/negative opposite of a number in the criteria
'This works with text just the same
Sub AutoFilterCopiedItems()
Dim Rng As Range
Dim Col As Range
Dim Sel As Range
Dim Sht As Worksheet
Dim Fld As Long
Dim Cel As Range
Dim Ary As Variant
Dim aStr As String
Dim vStr As Variant
Dim RngArea As Range
Dim NF As String
Dim X As Long
Dim Val As Double
Dim Changes As Long
Dim vErr As Boolean
Dim App As Application
Dim WF As WorksheetFunction
Dim LO As ListObject
Dim xNF As String
Dim NFType As String
Dim Headers As Range
Dim LastRow As Long
Set Sht = ActiveSheet
Set Sel = Selection
Set Col = Sel.EntireColumn
If Col.Columns.Count > 1 Then 'User selected more than one column
MsgBox "Please only select items in one column to filter"
Exit Sub
End If
'--------- Find the range that will be filtered ---------------------------------
On Error Resume Next
Set Rng = Sht.AutoFilter.Range 'Autofilter must be on
On Error GoTo 0
If Rng Is Nothing Then
Set LO = Sel.ListObject 'Structured Excel Table
If Not LO Is Nothing Then Set Rng = LO.DataBodyRange
End If
If Rng Is Nothing Then
With ActiveWindow
Set Cel = Sht.Cells(.SplitRow, Sel.Column) 'Row above the Freeze Panes line
End With
If Cel.Column > 1 Then
If Cel.Offset(0, -1) <> "" And Cel.Offset(0, 1) <> "" Then
Set Headers = Sht.Range(Cel.End(xlToLeft), Cel.End(xlToRight))
ElseIf Cel.Offset(0, -1) = "" And Cel.Offset(0, 1) <> "" Then
Set Headers = Sht.Range(Cel, Cel.End(xlToRight))
ElseIf Cel.Offset(0, -1) <> "" And Cel.Offset(0, 1) = "" Then
Set Headers = Sht.Range(Cel.End(xlToLeft), Cel)
End If
ElseIf Cel.Column = 1 Then
If Cel.Offset(0, 1) <> "" Then
Set Headers = Sht.Range(Cel, Cel.End(xlToRight))
ElseIf Cel.Offset(0, 1) = "" Then
Set Headers = Cel
End If
End If
X = 0
If Not Headers Is Nothing Then
For Each Cel In Headers
X = Sht.Cells(Sht.Cells.Rows.Count, Cel.Column).End(xlUp).Row
If X > LastRow Then LastRow = X
Next Cel
Set Cel = Headers.Resize(1, 1).Offset(0, Headers.Columns.Count - 1)
Set Rng = Sht.Range(Headers.Resize(1, 1), Intersect(Sht.Cells(LastRow, 1).EntireRow, Cel.EntireColumn))
End If
End If
If Rng Is Nothing Then 'Current Region is less accurate
Set Rng = Sel.CurrentRegion
Rng.AutoFilter
End If
'---------------------------------------------------------------------------------
Fld = Col.Column - Rng.Resize(1, 1).Column + 1 'Field number in filtered range
xNF = "mdy/[]hms:apE+" 'Characters to screen out non-numbers
NF = Sel.Areas(1).Resize(1, 1).NumberFormat 'Get number format of first cell
NFType = "Number" 'Start as a number
If NF = "@" Then 'Text
NFType = "Text"
ElseIf NF = "General" Then 'Not Formatted
NFType = "General"
Else
For X = 1 To Len(xNF)
If InStr(NF, Mid(xNF, X, 1)) > 0 Then 'Found a character that might be a date or time
NFType = "Text"
Exit For
End If
Next X
End If
vStr = CopyFromClipboard
' For X = 1 To Len(vStr)
' Debug.Print Asc(Mid(vStr, X, 1))
' Next X
If InStr(vStr, ",") > 0 Then
vStr = Replace(vStr, ", ", ",") 'remove spaces after comma
Ary = Split(vStr, ",") 'load into array
Else
vStr = Replace(vStr, vbCr, "")
Ary = Split(vStr, vbLf) 'load into array
End If
For X = 0 To UBound(Ary)
vErr = False 'reset vErr
On Error GoTo HolyErrorBatman 'Turn on error checking
Val = Ary(X) 'Change to number - may get an error if text
On Error GoTo 0
If NFType = "Text" Or vErr = True Then 'Text or Value Error
aStr = aStr & Chr(1) & Ary(X)
ElseIf NFType = "General" Then 'No value error
aStr = aStr & Chr(1) & Val
aStr = aStr & Chr(1) & Val * -1 'Opposite General
ElseIf NFType = "Number" Then 'still no value error
aStr = aStr & Chr(1) & Format(Val, NF) 'Formatted number
aStr = aStr & Chr(1) & Format(Val * -1, NF) 'Opposite formatted number
End If
Next X
Ary = Split(Mid(aStr, 2), Chr(1)) 'load into array again after first chr(1)
Rng.AutoFilter Field:=Fld, Criteria1:=Ary, Operator:=xlFilterValues 'Filter sheet
Exit Sub
HolyErrorBatman:
vErr = True
Resume Next
End Sub
