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

MrRajKumar

Active Member
Joined
Jan 29, 2008
Messages
291
Office Version
  1. 365
Platform
  1. Windows
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.
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
How about this: A little convoluted but tested out correctly my ficticious data...

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,224,568
Messages
6,179,591
Members
452,927
Latest member
whitfieldcraig

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 MrExcel.com.
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 "mrexcel.com".
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
Back
Top