Consulting

Results 1 to 8 of 8

Thread: What function should I use?

  1. #1

    What function should I use?

    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.

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    You could make a pivot table like this:
    2020-10-28_234748.jpg
    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:
    2020-10-28_235230.png
    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.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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,
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  4. #4
    Thank you Sam, that is what I have been doing. Just looking for a way to automate.

  5. #5
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  6. #6
    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

  7. #7
    I do it frequently enough that it makes sense to try to become more efficient. Thank you for your help.

  8. #8
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •