Results 1 to 5 of 5
  1. #1
    Lounger
    Join Date
    Jan 2014
    Posts
    30
    Thanks
    7
    Thanked 0 Times in 0 Posts

    Split Excel worksheet into multiple worksheets based on a column with VBA

    Hi,

    I tried the below codes to achieve results for huge database of around three hundred thousand records but it fails with error message, Run-time error 1004: Application defined or object defined error, Microsoft has stopped working, please some have a look I need to split the [DataSheet] database to multiple worksheets.

    Code:
    Sub Split_Companies()
         Dim d As Long, s As Long, dict As New Scripting.Dictionary
         dict.CompareMode = TextCompare
          With Sheets("DataSheet")
             For d = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                 If CBool(Len(Trim(.Cells(d, "A").Value))) Then
                     If Not dict.Exists(Trim(.Cells(d, "A").Value)) Then
                         dict.Add Key:=Trim(.Cells(d, "A").Value), Item:=vbNullString
                     End If
                 End If
             Next d
             For d = LBound(dict.Keys) To UBound(dict.Keys)
                 Application.DisplayAlerts = False
                 For s = 1 To Sheets.Count
                     If LCase(Sheets(s).Name) = LCase(dict.Keys(d)) Then
                         Sheets(dict.Keys(d)).Delete
                         Exit For
                     End If
                 Next s
                 Application.DisplayAlerts = True
                 .Copy After:=Sheets(Sheets.Count)
                 Sheets(Sheets.Count).Name = dict.Keys(d)
                 With Sheets(dict.Keys(d)).Cells(1, 1).CurrentRegion
                     .AutoFilter
                     .AutoFilter field:=1, Criteria1:="<>" & dict.Keys(d)
                     If Application.Subtotal(103, .Columns("A")) > 1 Then _
                         .Offset(1, 0).EntireRow.Delete
                     .AutoFilter
                 End With
             Next d
         End With
         dict.RemoveAll
         Set dict = Nothing
     End Sub

  2. #2
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi John

    I tested my routine below on a sample file with 350,000 records.
    I'm assuming your Company names are in column [A]
    I use a sort on the Company name column to put the records in order.
    The advantage is that the Company sheets will then be added in alphabetic order.
    The routine can be made to go faster, but on my test it took less than a minute anyway.

    Code:
    Sub extractByCompany()
    
    Sheets(1).Select                    'start on first Datasheet
    'Sort data by Company..
    [a1].CurrentRegion.Sort key1:=[a1], order1:=xlAscending, Header:=xlYes
    zCompany = [a2]                     'fetch first Company name
    
    Do Until zCompany = ""              'continue until all companies processed
    [a1].CurrentRegion.AutoFilter field:=[a1].Column, Criteria1:=zCompany
    zCompany = Trim(zCompany)               'remove any trailing spaces
    Sheets.Add After:=Sheets(Sheets.Count)  'add new sheet after all existing sheets
    Sheets(Sheets.Count).Name = zCompany    'assign name to new sheet
    Sheets(1).[a1].CurrentRegion.Copy       'copy filtered data to clipboard
    Sheets(zCompany).Paste                  'paste filtered data to Company sheet
    Sheets(zCompany).[a1].PasteSpecial Paste:=xlPasteColumnWidths   'set column widths
    Sheets(1).Select                                'switch back to first Datasheet
    [a1].CurrentRegion.Offset(1).EntireRow.Delete   'remove filtered records
    AutoFilterMode = False                          'cancel filter mode
    zCompany = [a2]                         'fetch next company name
    Loop                                    'repeat the processing for next Company
    
    MsgBox "Done!"
    
    End Sub
    Notes:
    Use a copy of your file for testing!

    zeddy

  3. #3
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi John

    In my post, I should have said that the datafile you process should only contain the one sheet, i.e. no existing company sheets.

    zeddy

  4. #4
    Lounger
    Join Date
    Jan 2014
    Posts
    30
    Thanks
    7
    Thanked 0 Times in 0 Posts
    Hi,

    Thanks Zeddy its perfect, Thanks.

  5. #5
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi John

    Glad you liked it.

    I have attached an example file of 5,000 records so that others may download the file and see how to extract data to separate worksheets. In my example, I am extracting data based on the column [G] entry (for State). I also tweaked the code a bit to show progress in the bottom statusbar.
    In the attached sample file, the routine has been renamed as extractByState
    zeddy-1.GIF

    zeddy
    Attached Files Attached Files

Posting Permissions

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