Consulting

Results 1 to 4 of 4

Thread: VBA Help splitting data based on a ID #

  1. #1
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    1
    Location

    VBA Help splitting data based on a ID #

    I need some help finishing some code. I have large tables that i need to split into individual files based on an identification number in a column. I will attach a sample document. I have already written everything after "selecting" all the rows with a certain ID number, meaning the transfer into a new file, etc. But I cant figure out an efficient way to select all the rows with the same ID # so i can copy them into its own file.

    Thank you for the help.
    Attached Files Attached Files

  2. #2
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,895
    Quote Originally Posted by cmcbeath View Post
    I need some help finishing some code.
    There's no code in your attachment to finish!
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    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
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,997
    Location
    Something like this should get you started


    Option Explicit
    
    
    Sub SplitID()
        Dim i As Long
        Dim r As Range
        Dim C As Collection
        Dim ws As Worksheet
        Dim wb As Workbook
        Dim ID As String, W As String
        
        Application.ScreenUpdating = False
        
        Set r = ActiveSheet.Cells(1, 1).CurrentRegion
    
        Set C = New Collection
        
        'make unique list
        On Error Resume Next
        For i = 2 To r.Rows.Count
            C.Add r.Cells(i, 1).Value, CStr(r.Cells(i, 1).Value)
        Next i
        On Error GoTo 0
    
    
        For i = 1 To C.Count
        
            'get the ID
            ID = C.Item(i)
            
            'delete ws with that ID just in case
            On Error Resume Next
            Application.DisplayAlerts = False
            Worksheets(ID).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            
            'add ws named ID
            Worksheets.Add
            Set ws = ActiveSheet
            ws.Name = ID
            
            'filter data on ID
            r.AutoFilter Field:=1, Criteria1:=ID
            
            'copy to ID ws
            r.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
    
    
            'get wb name
            W = ThisWorkbook.Path & Application.PathSeparator & ID & ".xlsx"
            
            'delete wb with that ID just in case
            On Error Resume Next
            Application.DisplayAlerts = False
            Kill W
            Application.DisplayAlerts = True
            On Error GoTo 0
            
            'copy ws to new wb
            ws.Move
            Set wb = ActiveWorkbook
            wb.SaveAs W, xlWorkbookDefault
            wb.Close False
            
            ThisWorkbook.Activate
        Next i
    
    
        ActiveSheet.AutoFilterMode = False
    
    
        Application.ScreenUpdating = False
    
    
        
        MsgBox "Done"
    
    
    End Sub
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,774
    This is all you need, using the builtin options in Excel (advancedfilter)

    Sub M_snb()
       If Sheets.Count = 1 Then Sheets.Add , Sheets(Sheets.Count)
        
       With Sheet1
         .Columns(1).AdvancedFilter 2, , .Cells(1, 6), True
         sn = .Cells(1, 6).CurrentRegion
         .Cells(1, 6).Offset(2).Resize(UBound(sn)).ClearContents
       
         For j = 2 To UBound(sn)
            .Cells(2, 6) = sn(j, 1)
            Sheet2.UsedRange.ClearContents
            .Cells(1).CurrentRegion.AdvancedFilter 2, .Cells(1, 6).CurrentRegion, Sheet2.Cells(1)
            Sheet2.Copy
            With ActiveWorkbook
               .SaveAs "G:\OF\" & sn(j, 1), 51
               .Close -1
            End With
         Next
       
       .Cells(1, 6).CurrentRegion.ClearContents
      End With
    End Sub

Tags for this Thread

Posting Permissions

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