Tjyylli

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.

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

    Next



    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



        objWorksheet.Rows(1).EntireRow.Copy

        objSheet.Activate

        objSheet.Range("A1").Select

        objSheet.Paste



         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

               objWorksheet.Rows(nRow).EntireRow.Copy



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

               objSheet.Range("A" & nNextRow).Select

               objSheet.Paste

               objSheet.Columns("A:I").AutoFit 

            End If



        Next



        objExcelWorkbook.SaveAs (CStr(varColumnValue)) 



   Next



err1:

     'Restore slow but necessary settings

     With Application

    .ScreenUpdating = True

    .Calculation = xlCalculationAutomatic

    .EnableEvents = True

     End With



End Sub