I just saw this and you can hack up my code to create a table for each criteria of one autofilter column you can set. Thus, your column had B1, B2, B3, when autofilter for the column is on, it will make a table B1_table, B2_table, B3_table from the filtered lists.
Make that column to autofilter a one column named range with all the data in it EXCEPT FOR the column heading.
Just ignore the comments and find how simple it is and mod it for what you are trying to do. It was so similar to what I had to do, I signed up just to post this code I loved it so much.
This lists your named ranges where you select the one to find unique fields within, to then turn each field of autofiltered data into tables per criteria in the autofiltered results of that column as a named range target. You can just hard code the proper connections.
Your filter column is a named range to list here, for the logic to follow:
Private Sub Command3_Click()
Dim Object
Dim Excel As Object
Dim elem As Object
Dim excelSheet As Object
Dim application As Object
Dim Array1 As Variant
Dim Count, RowNum As Integer
Dim Cellcnt
Dim Rowcnt
Dim Colcnt
Dim rngObj As Object
Dim Cx As String
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
On Error GoTo xoop:
COMBOXXLNAME(0).BackColor = vbBlack
For X = 1 To Excel.application.Names.Count
NAMEX = Excel.application.Names(X).Name
ipos = InStr(1, NAMEX, "!_FilterDatabase")
If ipos = 0 Then
COMBOXXLNAME(0).AddItem Excel.application.Names(X).Name
COMBOXXLNAME(1).AddItem Excel.application.Names(X).Name
Text1.Text = Text1.Text & Excel.application.Names(X).Name & vbCrLf
End If
Next
If COMBOXXLNAME(0).ListCount > 0 Then
COMBOXXLNAME(0).Text = COMBOXXLNAME(0).List(0)
End If
Exit Sub
xoop:
MsgBox Err.Description & ":" & vbCrLf & _
vbCrLf & _
"Is an Excel2000 session running?"
COMBOXXLNAME(0).BackColor = &H404040
End Sub
Then from a named range you select to check in the above, unique filter items are listed here, which creates the filer_item to excel_tables data target.
Private Sub Command2_Click()
Dim Thisdrawing As Object
'Set acadapp = GetObject(, "autocad.application")
'Set Thisdrawing = acadapp.activedocument
Dim Object
Dim Excel As Object
Dim elem As Object
Dim excelSheet As Object
Dim application As Object
Dim Array1 As Variant
Dim Count, RowNum As Integer
Dim Cellcnt
Dim Rowcnt
Dim Colcnt
Dim rngObj As Object
Dim Cx As String
On Error GoTo ERRZONE:
COMBOXXLNAME(0).BackColor = vbBlack
If COMBOXXLNAME(0).Text = "" Or COMBOXXLNAME(0).Text = "Excel Defined Names" Then
MsgBox "Select, or enter an Excel range name."
COMBOXXLNAME(0).BackColor = &H404040
Exit Sub
End If
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could load Excel but Can't.", vbExclamation
End
End If
End If
On Error GoTo 0
'Excel.Visible = True
'Excel.Workbooks.Add
' Excel.Sheets("Sheet1").Select
'Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
'Set Excelapp = Excel.application
'EXCELAPP.
COMBOXXLNAME(0).BackColor = vbBlack
If COMBOXXLNAME(0).Text = "" Or COMBOXXLNAME(0).Text = "Excel Defined Names" Then
MsgBox "Select, or enter an Excel name."
COMBOXXLNAME(0).BackColor = &HC0C0&
Exit Sub
End If
On Error GoTo ERRZONE:
'FOR rCNT = 0 TO
'Range("I2").Select
'Ccnt = Excel.application.Range("Sheet1!_FilterDatabase").Columns.Count
'rCNT = Excel.application.Range("Sheet1!_FilterDatabase").Rows.Count
'Cellcnt = Excel.application.Range("Sheet1!_FilterDatabase").Cells.Count
'CellVal = Excel.application.Range("Sheet1!_FilterDatabase").Cells(.Value
Ccnt = Excel.application.Range(COMBOXXLNAME(0).Text).Columns.Count
Rcnt = Excel.application.Range(COMBOXXLNAME(0).Text).Rows.Count
Cellcnt = Excel.application.Range(COMBOXXLNAME(0).Text).Cells.Count
List2.Clear
For z = 1 To Rcnt
For C = 1 To Ccnt
cellval = Excel.application.Range(COMBOXXLNAME(0).Text).Cells(z, C).Value
List2.Text = cellval
If List2.ListIndex = -1 Then
If cellval <> "" Then
List2.AddItem cellval
End If
End If
'zz = AddUnique(CellVal, ListAdd)
Next C
Next z
List1.AddItem Ccnt
List1.AddItem Rcnt
List1.AddItem Cellcnt
Command10.Enabled = True
Exit Sub
ERRZONE:
MsgBox Err.Description & " NUMBER: " & Err.Number
'On Error Resume Next
'Excel.application.Range("IDTAB").Select
End Sub
Then this code creates tables from the unique autofilter list items from your target defined range of the one column you are filtering, naming the table as the item filtered.
Private Sub Command10_Click()
Dim Excel As Object
Dim excelSheet As Object
Dim excelSheet2 As Object
Dim Range As Object
'8-24-2018
'Uses table data from att2Excel format in SampleTable2 to
'create tables from autofiltered criteria in a named range
'added function to prepare table for ACLA format
'On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
Set excelSheet = Excel.ActiveWorkbook.Sheets("Table_Complete")
Excel.Visible = True
'where filter criteria is listed
For i = 0 To List2.ListCount - 1
'from an utofiltered column on this table, can be made "Sheet1", etc.
Excel.ActiveWorkbook.Sheets("Table_Complete").Select
DoEvents
strFILT = Trim(List2.List(i)) 'Trim(str3)
'ADDED DUE TO acacia_greggii example, "acacia greggi" without underscore
''strFILT = Replace(strFILT, " ", "_")
'ERROR REPORT
'THIS TIME ATTRIP PURPLE, SET AUTOFILTER BEFOREHAND=WORKED
If i = 0 Then
'be on sheet "Table_Complete"
'can delete this end-if if autofilter is already on
Excel.application.Range("A1:Z1").Select
'Excel.application.Range("TestFiler").Select
'============
'added this to set autofilter field val automaically
strRange = COMBOXXLNAME(0).Text
strFC = Excel.application.Range(strRange).Column
'MsgBox strFC
'Exit Sub
'Excel.application.Selection.AutoFilter
'IF YOU GET AN ERROR AFTER IT WAS WORKING AFTER
'USIN AUTOFILTER IN WB EVEN ONE TIME ONLY
'TURN OFF AF AS IN REM ABOVE
'symptom is EXCEL AF FREEZE UP, NO DROP DOWNS AVAILABLE
'I REMMED IT IN CODE ABOVE, MAY TURN OFF AF IN EXCE AS WELL
'==================
'GO FIGURE, SOMETIMES HAVING AFILTER ON
'IS THE ONLY WAY IT WORKS
End If
'SET FIELD TO AUTOFILTER COLUMN (EXPLICIT=10) OR NO DATA RETURNED WITH NO ERROR
'if problem make field explicit to column loc rather than strFC var
'Excel.application.Selection.AutoFilter Field:=strFC, Criteria1:=strFILT
Excel.ActiveWorkbook.Sheets("Table_Complete").Select
Excel.application.Selection.AutoFilter Field:=10, Criteria1:=strFILT
'Excel.ActiveWorkbook.Sheets("Table_Complete").Select
excelSheet.Range("A1", excelSheet.Range("A1").End(xlToRight).End(xlDown)).Cells(1, 1).Select
With Excel.application.Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
strFILT2 = "NUMBER"
'NAME RANGE
STRPLANTFILTER = Replace(strFILT, " ", "_") 'Trim(Trim(strFILT2)) & "_RNG_" & Trim(Str(i))
'excelSheet.Range("A1", excelSheet.Range("A1").End(xlToRight).End(xlDown)).Name = STRPLANTFILTER
'excelSheet.Range("A1", excelSheet.Range("A1").End(xlToRight).End(xlDown)).Name = STRPLANTFILTER
excelSheet.Range("A1", excelSheet.Range("A1").End(xlToRight).End(xlDown)).Select
Excel.application.Selection.Copy
'ADD SHEET
Excel.Sheets.Add
'NAME SHEET - GRAB THE FIRST "NEW"
Excel.Sheets(i + 1).Name = STRPLANTFILTER
'SET NEW SHEET
Set excelSheet2 = Excel.ActiveWorkbook.Sheets(STRPLANTFILTER)
'OPTIONAL FOCUS SET
'Excel.Visible = True
'SELECT NEW SHEET
Excel.application.Sheets(STRPLANTFILTER).Select
'SELECT THE FIRST CELL FOR PASTE
Excel.ActiveWorkbook.Sheets(STRPLANTFILTER).Range("A1").Select
'PASTE INTO CURRENT SHEET
Excel.ActiveSheet.Paste
'SELECT TO EXTENTS WITH DATA VALUE IN CELL
excelSheet2.Range("A1", excelSheet2.Range("A1").End(xlToRight).End(xlDown)).Select
With Excel.application.Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
excelSheet2.Range("A1", excelSheet2.Range("A1").End(xlToRight).End(xlDown)).Name = STRPLANTFILTER '& "_FILT"
strCURRENTRANGE = STRPLANTFILTER '& "_FILT"
'CLEAR THE CLIPBOARD, CUTCOPY MODE TO FALSE
'Excel.application.CutCopyMode = False
'GET COLUMN COUNTFOR NEW RANGE FOR AUTOFIT ARG
Ccnt = excelSheet2.Range(strCURRENTRANGE).Columns.Count
'LOOP TROUGH THE COLUMNS
For C = 1 To Ccnt
'AUTOFIT EACH COLUMN
excelSheet2.Range(strCURRENTRANGE).Columns(C).AutoFit
Next C
'FILTERED DATA FROM SHEET, IS USED TO CREATE A NEW TABLE
'WITH THE NAME OF THE RANGE OF THE FILTERED DATA
If CheckAcTables.Value = 1 Then
'this opetion selects certain columns rather than the whole table created
'from the named range unique filtered items
Excel.application.ActiveSheet.Columns("O").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("N").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("M").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("L").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("K").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("J").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("I").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
'Excel.application.ActiveSheet.Columns("H").EntireColumn.Select
'Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("D").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
Excel.application.ActiveSheet.Columns("A").EntireColumn.Select
Excel.application.Selection.Delete 'Shift:=xlToLeft
End If
Next i
Excel.ActiveWorkbook.Sheets("Table_Complete").Select
Excel.application.ActiveSheet.AutoFilterMode = False
'AUTOFILTER STUFF
'Excel.application.Selection.AutoFilter Field:=1 ', Criteria1:="(All)"
'AUTOFILTER STUFF
Exit Sub
ZOOP:
MsgBox Err.Description
'RETAINED FOR SETTING ONE SHEETS CELLS TO ANOTHE RANGES CELL VALUES
'STEP THROUGH THE COLUMNS
'For C = 1 To excelSheet.Range(strPLANTFILTER).Columns.Count
'AND EACH ROW IN IT
'For R = 1 To excelSheet.Range(strPLANTFILTER).Rows.Count
'Excel.ActiveWorkbook.Sheets(strPLANTFILTER).Range("A1").Cells(1, 1).Value = "YES"
'SET VALUE OF NEW SHEETS CELLS TO THAT OF FILTERED SHEET
'Excel.ActiveWorkbook.Sheets(strPLANTFILTER).Range("A1").Cells(R, C).Value = Trim(excelSheet.Range(strPLANTFILTER).Cells(R, C).Value)
'excelSheet2.Range("A1", Range("A1").End(xlToRight).End(xlDown)).Select
'Excel.ActiveWorkbook.Sheets(strPLANTFILTER).Range("A1").Columns.AutoFit
'Next R
'Next C
'excelSheet2.Range("A1", Range("A1").End(xlToRight).End(xlDown)).Name = strPLANTFILTER
'Range("D3:D50").Select 'b
'Selection.Copy
End Sub