PDA

View Full Version : What function should I use?



MichaelB
10-28-2020, 11:20 AM
I have a large set of data, about 4500 rows by several columns. The data is a lot of part numbers that I have sorted by bin location(column A). I want to take that big master data list and separate it into multiple sheets, one sheet for each different bin.

For example:



B4
SP 546
24


B4
SP 548
16


B4
SP 550
5


B4
SP 578
5


B4
SP 580
35


B5
AA5Z 00815 B
2


B5
AA5Z 00815 C
2


B5
ACPZ 1012 B
7


B5
ACPZ 1012 H
11


B5
ACPZ 1012 M
4


B5
AC3Z 1S175 A
2




I would want this data split onto 2 pages, one page would have all of the B4 data and the second page all of the B5 data.

Thank you for your input.

p45cal
10-28-2020, 04:53 PM
You could make a pivot table like this:
27371
Then double-click on each of the subtotal values in turn; this should add a new sheet each time which you can rename according to column A on those sheets.
eg:
27372
If you have many bins, you can right-click the header Bin in the pivot table, and choose Expand/Collapse, then choose Collapse entire field, which should bring all the subtotals next to each other.

SamT
10-29-2020, 11:09 AM
Sort the sheet on Column A. Copy all the B4 to one sheet and all the B5 to the other.

Faster than copying all the code any of us write and pasting it into a Module,

MichaelB
10-29-2020, 12:19 PM
Thank you Sam, that is what I have been doing. Just looking for a way to automate.

SamT
10-29-2020, 02:55 PM
You do this frequently?

Sub SplitInTwoSheets()

Dim ThisSht As Worksheet
Dim LastCol As Long
Dim Cel As Range

Application.ScreenUpdating = False
Set ThisSht = ActiveSheet

With ThisSht.Range("A1").CurrentRegion
LastCol = .ColumnsCount

For Each Cel In .Range("A:A")

'Add Sheet if needed
'True When False Structure
On Error Resume Next
If Not Sheets(Cel).Name = Cel Then
Sheets.Add
ActiveSheet.Name = Cel
End If
On Error GoTo 0

'Copy Bin Items to new Sheet
'Without Bin number
Cel.Offset(, 1).Resize(, LastCol - 1).Copy Sheets(Cel).Cells(Rows.Count, "A").End(xlUp).Offset(1)
'With Bin Number
'Cel.Resize(, LastCol).Copy Sheets(Cel).Cells(Rows.Count, "A").End(xlUp).Offset(1)
Next Cel
End With

Application.ScreenUpdating = True
End Sub

xSkyscraper
10-29-2020, 03:08 PM
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

MichaelB
10-29-2020, 03:09 PM
I do it frequently enough that it makes sense to try to become more efficient. Thank you for your help.

xSkyscraper
10-29-2020, 03:34 PM
You can just get the piece which copies a target autofiltered value "B5", etc, if you just have a couple. I did it because there could be tens of autofiltered criteria I had to make into whole tables automatically to save some hours. Inserting sheets, autofiltering, copying, on possibly tens of criteria listed per project, having to be done multiple times at times, was quite time consuming at that time. That is why I loved that trick, it literally saved hours I could then use for less tedious things, like more solutions.