I have an Excel with a lot of rows 20.000+ that I want to split based on the creation date (date only without time) and save as separate files.

The file looks like:

Can anyone help me with this. I have tried changing some VBA codes I found on this site but ran against errors that I couldn't solve.

  • 6
    Please share the VBA code that didn't work for you and the error you received. – Worthwelle Mar 8 '19 at 16:29
  • Is there a reason you're looking at VBA rather than filtering by date, then copy/cut and pasting the relevant data to another sheet? – Alex M Mar 8 '19 at 18:26
  • I think you are looking to copy Rows into New Workbooks based on Creation Date, if so edit the post and remove Split Sheet. And, are you like to copy Rows to New Sheets based on Creation Date? – Rajesh S Mar 9 '19 at 5:46

Thanks to Shirley Zhang.
Original from: (datanumen.com/blogs/2-fast-means-to-split-an-excel-worksheets-contents-into-multiple-workbooks-based-on-a-specific-column) edited by me.

Due to create, edit and save workbooks, it takes a long time to calculate 20.000+ lines. Maybe more than 15 minutes.

Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet

    Dim aCol As String
    aCol = "G" '<- Change Source-Column here

    On Error GoTo err1
     'Speed up a little bit
     With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
     End With

    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

    Set objDictionary = CreateObject("Scripting.Dictionary")

     For nRow = 2 To nLastRow
        'Get the specific Column
        'Here my instance is "B" column
        'You can change it to your case

        'strColumnValue = objWorksheet.Range("B" & nRow).Value
        strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "mm_dd_yyyy") '<- Set the filter and filename

        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If

    varColumnValues = objDictionary.Keys

    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)

        'Create a new Excel workbook
        Set objExcelWorkbook = Excel.Application.Workbooks.Add

        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name


         For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range(aCol & nRow).Value) = CStr(varColumnValue) Then
               'Copy data with the same column "B" value to new workbook

               nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
               objSheet.Range("A" & nNextRow).Select
            End If


        objExcelWorkbook.SaveAs (CStr(varColumnValue)) 


     'Restore slow but necessary settings
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
     End With

End Sub
  • By using a collection as the Dictionary item (instead of 1) and adding the ranges to these collections, the code only needs to process the source once. Further, by looping on a "Date File's" collection, and creating a resultant Union Range, all the rows for a date can be processed together (one Range [many rows] one copy/paste per file). Here are the stats for this approach: 20834 rows with 8 distinct dates (8 new files) took 37.7 seconds. The source had 23 columns and halve of those had formulas. Using pastespecial to copy everything (including formulas) the time increased 20% to 45 seconds. – Ted D. Mar 11 '19 at 7:14
  • you may want to consider closing the new files in addition to saving them. Closing is included in the time amounts. Let me know if you would like to see this answer. – Ted D. Mar 11 '19 at 7:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.