AutoFilter Selected Items - Selecting non-structured Table

[Jeffrey Mahoney]

I created a tool to allow the user to select multiple items within a single column that they want filtered. The problem was that I would try to add items to the filter and I would inevitably forget to click "Add current selection to filter" and then erase the previous items I had selected. One of the features I added in the code below is to also select the negative/positive opposite. This is handy for financial people that are dealing with a large number of repeating accruals.

In the code below, the filtered range is found either by 1) the range already established by the filter, 2) the range in a structured Excel table, or 3) the CurrentRegion.

The problem is with CurrentRegion. It may select all the cells with data. In most of my cases, my tables may start on row 5 with some information above the table including column totals.

Does anybody know a cleaner way to select only the data within the table (non-structured). Example below:

00KRC 20230717.XLSX
	A		C		E	F	G	H	I	J
1	Exported from Application on 17-Jul-2023 08:43:31
2	Posted
3	Project: ZAP1234 Some Project Name Object: 12345 12345				70,010,124.60	Dec-2020 - Jul-2023
4	CBS Path ID		Description		Cost	Date	Data Source	WO	PO	YearMonth
5	ZAP-1234|987123|987|987123|987123|987123|C337536		SAP PR4 Postings for 07/14/2023		1,234.00	14-Jul-2023	SAPPR4	123456	C123456	202307
6	ZAP-1234|987123|987|987123|987123|987123|C322431		SAP PR4 Postings for 07/14/2023		1,349.48	14-Jul-2023	SAPPR4	123456	C123456	202307
7	ZAP-1234|987123|987|987123|999999|987123|C338474		SAP PR4 Postings for 07/14/2023		1,464.96	14-Jul-2023	SAPPR4	123456	C123456	202307
8	ZAP-1234|987123|987|987123|999999|987123|C340367		SAP PR4 Postings for 07/14/2023		1,580.44	14-Jul-2023	SAPPR4	123456	C123456	202307
Posted

Cell Formulas
Range	Formula
E3	E3	=SUBTOTAL(109,E5:E1095)
F3	F3	=TEXT(SUBTOTAL(105,F5:F1095),"mmm-yyyy")&" - "&TEXT(SUBTOTAL(104,F5:F1095),"mmm-yyyy")
E6:E8	E6	=+E5+115.48

'This will filter multiple selected items in a single column that you select
'You may select multiple cells and ranges within the same column
'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 AutoFilterItems()
  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 RngArea As Range
  Dim NF As String
  Dim X As Long
  Dim Val As Double
  Dim vStr As String
  Dim Changes As Long
  Dim vErr As Boolean
  Dim App As Application
  Dim WF As WorksheetFunction
  Dim LO As ListObject
  
  
  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                                      '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
  
  NF = Sel.Areas(1).Resize(1, 1).NumberFormat                 'Get number format of first cell
  
  'load all cells into string
  For Each RngArea In Sel.Areas                               'Even ranges of cells
    For Each Cel In RngArea
      vStr = Cel.Value
      If NF <> "General" Then vStr = Format(Cel, NF)          'Format function doesn't like General
      aStr = aStr & Chr(1) & vStr
      
      '----- Section for adding Opposites -----
      vErr = False                                              'reset vErr
      On Error GoTo NumberError                                 'Turn on error checking
      Val = Cel.Value                                           'Change to number - may get an error if text
      On Error GoTo 0                                           'turn off error checking
      If vErr = False Then                                      'is number?
        vStr = Val * -1
        If NF <> "General" Then vStr = Format(Val * -1, NF)
        aStr = aStr & Chr(1) & vStr                           'add oposite value to string
      End If
      '-------------------------------------------
    Next Cel
  Next RngArea
  Ary = Split(Mid(aStr, 2), Chr(1))                            'load into array separated by spaces
  
  Rng.AutoFilter Field:=Fld, Criteria1:=Ary, Operator:=xlFilterValues   'Filter sheet
        
  Exit Sub
  
NumberError:
  vErr = True
  Resume Next

End Sub

 

[GlennUK]

Can you test the first few cells of column A for the expected title row entry "CBS Path ID", and go from there?

 

[Jeffrey Mahoney]

So, this was created to handle any kind of data set or excel table, not just one table.

When the auto filter is off and the table is not a structured Excel table, I only have CurrentRegion to help select only the table. The problem is CurrentRegion selects all contiguous rows including data not associated with the table.

 

[GlennUK]

I see your point ... so you need to do some generic testing, like, find the first row that has the same number of non-blank cells for the width of the range same as the current region width, maybe? Does that logic seem viable to you?

 

[Jeffrey Mahoney]

So here is another iteration. I added code that looks at the Freeze Pane row to determine the table bounds. So at this time I can test for the AutoFilter Range, the Excel Table Range, the Freeze Pane Row. If the user doesn't set any of those, I should just throw up a message box letting them know the macro can't determine the range of the table.

I also added code to check the number format a little closer. I didn't want to filter for negative dates and times.

'This will filter multiple selected items in a single column that you select
'You may select multiple cells and ranges within the same column
'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 AutoFilterItems()
  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 RngArea As Range
  Dim NF As String
  Dim X As Long
  Dim Val As Double
  Dim vStr As String
  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
  
  '------Find range by the Freeze Pane Row -------------------------------------------
  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                                              'not column A
      If Cel.Offset(0, -1) <> "" And Cel.Offset(0, 1) <> "" Then        'middle of table
        Set Headers = Sht.Range(Cel.End(xlToLeft), Cel.End(xlToRight))
      ElseIf Cel.Offset(0, -1) = "" And Cel.Offset(0, 1) <> "" Then     'left column of table
        Set Headers = Sht.Range(Cel, Cel.End(xlToRight))
      ElseIf Cel.Offset(0, -1) <> "" And Cel.Offset(0, 1) = "" Then     'right column of table
        Set Headers = Sht.Range(Cel.End(xlToLeft), Cel)
      End If
    ElseIf Cel.Column = 1 Then                                          'Column A
      If Cel.Offset(0, 1) <> "" Then                                    'Left column, Headers to the right
        Set Headers = Sht.Range(Cel, Cel.End(xlToRight))
      ElseIf Cel.Offset(0, 1) = "" Then                                 'One column in table
        Set Headers = Cel
      End If
    End If
    X = 0
    If Not Headers Is Nothing Then
      For Each Cel In Headers                                           'Headers established, get range of table
        X = Sht.Cells(Sht.Cells.Rows.Count, Cel.Column).End(xlUp).Row   'Find last row at the bottom of all columns
        If X > LastRow Then LastRow = X
      Next Cel
                                                                        'Set the range of the table
      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+"                                      'Filter for 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                                  'General and number
    NFType = "General"
  Else
    For X = 1 To Len(xNF)                                     'Test if format is not a number
      If InStr(NF, Mid(xNF, X, 1)) > 0 Then
        NFType = "Text"
        Exit For
      End If
    Next X
  End If
  
  'load all cells into string
  Astr = ""
  For Each RngArea In Sel.Areas                               'Even ranges of cells
    For Each Cel In RngArea
      vErr = False                                              'reset vErr
      On Error GoTo NumberError                                 'Turn on error checking
      Val = Cel.Value                                           'Change to number - may get an error if text
      On Error GoTo 0
      
      If NFType = "Text" Or vErr = True Then                      'Text or Error
        Astr = Astr & Chr(1) & Cel.Value
      ElseIf NFType = "General" Then                              'No error
        Astr = Astr & Chr(1) & Val
        Astr = Astr & Chr(1) & Val * -1                           'Opposite General
      ElseIf NFType = "Number" Then                               'still no error
        Astr = Astr & Chr(1) & Format(Val, NF)                    'Formatted number
        Astr = Astr & Chr(1) & Format(Val * -1, NF)               'Opposite formatted number
      End If
    Next Cel
  Next RngArea
  Ary = Split(Mid(Astr, 2), Chr(1))                                     'load into array
  Rng.AutoFilter Field:=Fld, Criteria1:=Ary, Operator:=xlFilterValues   'Filter sheet
        
  Exit Sub
  
NumberError:
  vErr = True
  Resume Next

End Sub

 

[Jeffrey Mahoney]

My code calls the function below

'Get text from Clipboard
Function CopyFromClipboard() As String

  Dim objCP As Object
  Dim Astr As String
  
  Set objCP = CreateObject("HtmlFile")
  On Error Resume Next
  Astr = objCP.ParentWindow.ClipboardData.GetData("text")
  On Error GoTo 0
  
  'Remove Hard Return from cell copy
  CopyFromClipboard = Replace(Astr, Chr(13) & Chr(10), "")
  
End Function

 

[Akuini]

my tables may start on row 5 with some information above

So basically you need to know at which row the header is (on a non-structured table) ?

 

[Jeffrey Mahoney]

So basically you need to know at which row the header is (on a non-structured table) ?

Yes, I guess so.

 

[Akuini]

Yes, I guess so.

Maybe this:
Say in all cases the header must be above row 10.
Loop from row 10 to 1 until the value is not a number.
Something like this:

lastRow = get the last row here
xcol = Selection.Column

For i = 10 To 1 Step -1
    If Cells(i, xcol) <> "" And Not IsNumeric(Cells(i, xcol)) Then Exit For
Next

'get the range
Set Rng = Range(Cells(i , xcol), Cells(lastRow, xcol))
Debug.Print Rng.Address