Large data set create breakouts from two tabs


Board Regular
Oct 13, 2004
I have a complicated problem where I have a file with two tabs. There are about 60,000 lines per tab. I had to break it up in order to work with it in Excel.

What I need to do is go through each tab and line by line add the line to a new file based upon the content of the column "Company Code" (lets says its column C.

A folder would need to be created in the same folder as this sheet and a file would be created with the same name as the company code (i.e. 1125 would be 1125.xls) in that new folder. That line would be added to the next line of that new file. If the file already exists it would just be added accordingly. There are probably 100 different Company Codes so you should end up with 100 new files.

The file has columns A through K and all the date would be copied over. The headers across the top of each of the new files should be:

Card Holder name
Company Code
Company Name
Transaction Date
Post Date
Merchant Name
Source Amt
Status Updated

Hope this makes sense...


Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

how are the files currently ordered in you workbook? would this order need to be carried over to the new workbooks?

thanks. ben.
Upvote 0
Right now the only file that exists is the main one with two tabs and it is not sorted in any particular order. So there can be data for the same company codes on tab 1 and 2 (they are actually labeled 1 and 2 if that helps).

I am trying to break up all the date to separate files usings Company Code as the source for this division.


Upvote 0

sorry for the long wait -- i had a bit of trouble :)

anyways, i think this should do what you want. what this program does is

1)gets directory to save files in from the user
2)sort your source sheet by the company code
3)use advanced filter to create a list of unique company codes
4)use countif on this unique list to create counts by company code
5)copy ranges from your dataset using these counts to self-titled worksheets within the source workbook (or creates a self-titled sheet if none exists)
6)repeat (1-4) for each source sheet
7)copy each non-source sheet to its own self-titled workbook

im going to warn you that this might take a bit of time to run; excel isn't that fast at creating and saving workbooks, so give this a bit of time to go.

if you have any questions or issues arise, let me know.

cheers. ben.
Sub CreateCompanyWorkbooks()

    Dim MyDirectory As String
    Dim SourceCount As String
    Dim Msg As Integer
    SourceCount = Application.InputBox("Enter the # of source sheets:", Title:="Get Source Sheet Count", Type:=2)
    If Not IsNumeric(SourceCount) Then
        MsgBox "Invalid # of source sheets.", vbCritical
        Exit Sub
    End If
    Msg = MsgBox("Are your source sheets named as consecutive integers (1, 2, ...)?", vbYesNo)
    If Msg = vbYes Then
        MyDirectory = Application.GetSaveAsFilename("Select directory to save new files", Title:="Get Directory")
        MyDirectory = Left(MyDirectory, InStrRev(MyDirectory, "\"))
        Application.ScreenUpdating = False
        Call CreateCompanyWorksheets(SourceCount)
        Call MoveSheets(MyDirectory)
        Application.ScreenUpdating = True
        MsgBox "Please change your source sheet names."
    End If
End Sub
Private Sub CreateCompanyWorksheets(SourceCount As String)

    Dim CodeColumn As Integer
    Dim HeaderRow As Integer
    Dim StartRow As Long

    Dim DataRange As Range, CodeRange As Range
    Dim UniqueRange As Range, CountRange As Range
    Dim c As Range, CopyRange As Range

    Dim ws As Worksheet, sht As Object
    Dim i As Integer, break As Integer

    Application.ScreenUpdating = False

    CodeColumn = 3 '<-- Set this equal to the column number for the Company Code
    StartRow = 2 '<-- Set this equal to the row number of the first non-header row

    For i = 1 To SourceCount
        Set ws = Worksheets("" & i & "")
'       Create a sorted range to holding all worksheet data
        Set DataRange = ws.UsedRange
        DataRange.Sort Key1:=Cells(1, CodeColumn), Order1:=xlAscending, Header:=xlYes

'       Create a range of all company codes
        Set CodeRange = ws.Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))
'       Create a range of the unique company codes
        CodeRange.AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, ws.UsedRange.Columns.Count + 2), Unique:=True
        Set UniqueRange = ws.Range(Cells(2, ws.UsedRange.Columns.Count), Cells(Rows.Count, ws.UsedRange.Columns.Count).End(xlUp))
'       Create a range which contains the # of occurrences of each company code
        Set CountRange = UniqueRange.Offset(0, 1)
        CountRange.FormulaR1C1 = "=COUNTIF(" & CodeRange.Address(ReferenceStyle:=xlR1C1) & ", RC[-1])"
        Set StartRange = DataRange.Range(Cells(StartRow, 1), Cells(StartRow, DataRange.Columns.Count))

'       Loop through unique company codes and copy matching cells to self-titled worksheets
        For Each c In UniqueRange.Cells
            Set EndRange = StartRange.Offset(CountRange.Cells(c.Row - 1, 1).Value - 1, 0)
            Set CopyRange = Range(StartRange, EndRange)
            break = 0
            For Each sht In ActiveWorkbook.Sheets
'               If a worksheet name matches the company code then
                If CStr(c.Value) = sht.Name Then
'                   Copy the company codes to the appropriate sheet
                    sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
                    break = 1
                    Exit For
                End If
            Next sht
'           If the worksheet does not already exist, add it to the workbook
            If break <> 1 Then
                Worksheets.Add.Name = c.Value
'               Copy header and appropriate company codes to new self-titled sheet
                DataRange.Range(Cells(1, 1), Cells(1, DataRange.Columns.Count)).Copy
                Worksheets("" & c.Value & "").Range("A1").PasteSpecial
                Worksheets("" & c.Value & "").Range("A2").PasteSpecial
            End If

'           Move to the first uncopied line in the DataRange
            Set StartRange = EndRange.Offset(1, 0)
        Next c

'       Delete added ranges from source sheets
    Next i

End Sub

Private Sub MoveSheets(MyDirectory As String)

    Dim ws As Worksheet
    Dim MyName As String
    Application.DisplayAlerts = False
'   Moves each sheet in the workbook (excepting the source sheets) to a new workbook
    For Each ws In ThisWorkbook.Worksheets
        MyName = ws.Name
        If MyName <> "1" And MyName <> "2" Then
            ActiveWorkbook.SaveAs Filename:=MyDirectory & MyName
        End If
    Next ws
    Application.DisplayAlerts = True
End Sub
Upvote 0

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back