Move Records to New a Workbook For Each Dates in the Column

[MrRajKumar]

Hello All,

I have a workbook with 500K+ records. In column A has dates with times, ie: 1/1/2024 12:01 AM, 1/1/2024 11:39 PM etc.... They are sorted in ascending order.
What I am trying to achieve is create a separate workbook for each date with the help of VBA.

Data in column A:D

1) Look for A2:ALastRow in the data set.
2). Move each day's data (A:D) to a new workbook.
3). Convert new workbook data to Table format. Default name Table1 will be enough.
4). Save the new workbook in YYYYMMDD format in the folder: Environ("Username")&"\Desktop\Data\"
5). Repeat the process for next date in column A.

I hope my explanation is clear. If not please feel free to ask. Thank you.

 

[igold]

How about this: A little convoluted but tested out correctly my ficticious data...

Sub ToBooks()

    Dim path As String, hdr
    Dim i As Long, x As Long, r As Long, col As Long
    Dim arrT, arr, arrN
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    hdr = Range("A1:D4")
    arr = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    With CreateObject("Scripting.Dictionary")
        For x = LBound(arr) To UBound(arr)
            arr(x, 1) = Format(arr(x, 1), "mm/dd/yyyy hh:mm:ss")
            If Not IsMissing(Left(arr(x, 1), 10)) Then .Item(Left(arr(x, 1), 10)) = 1
        Next
        arrT = .keys
    End With
    For x = 0 To UBound(arrT)
        If r > 1 Then GoTo Ns
nxt:
        arrN = Empty
        ReDim arrN(1 To UBound(arr, 1), 1 To 4)
        If x > UBound(arrT) Then
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
            MsgBox "Operation Complete"
            Exit Sub
        End If
        r = 1
        For i = 1 To UBound(arr)
            If Left(arr(i, 1), 10) = arrT(x) Then
                For col = 1 To 4
                    arrN(r, col) = arr(i, col)
                Next
                r = r + 1
            End If
        Next
    Next
Ns:
    Dim wb As Workbook: Set wb = Workbooks.Add
    With wb.Worksheets("Sheet1")
        .Range("A1:D1") = hdr
        .Range("A2").Resize(UBound(arrN, 1), UBound(arrN, 2)) = arrN
        .Columns.AutoFit
    End With
    
    Call mt
    GoTo nxt

End Sub

Sub mt()

    Dim path As String, nam As String
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim rng As Range: Set rng = ws.UsedRange
    
    ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _
        "Table1"
    path = Environ("Username") & "\Desktop\Data\"
    nam = Left(Range("A2"), 10)
    nam = Format(nam, "mmddyyyy")
    
    ActiveWorkbook.SaveAs "C:\Users\" & path & nam & ".xlsx"
    ActiveWorkbook.Close

End Sub