VBA Code to Seperate a Column into Worksheets By Date Column

[dburge07]

I have a list of data that has a specific date value for each row, and I want to separate the data by date using VBA. I would like to create a new worksheet for each date found and paste the ENTIRE ROW to the created worksheet based on date. I know this is going to create a lot of worksheets, but that's ok -- because the next step is analyzing the time column to break the data down further into Day/Night based on time.

[Sintek]

Sub J3v16()
Dim Data, Dict As Object, i As Long, Sht As String
Application.ScreenUpdating = False
Set Dict = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1").Cells(1).CurrentRegion
    Data = .Value
    For i = 2 To UBound(Data)
        If Not Dict.exists(Data(i, 2)) Then
            Dict.Add Data(i, 2), Nothing
            Sht = Format(Data(i, 2), "DDMMYYYY") '! Sheet names cannot contain "/" Character
            .AutoFilter 2, CStr(Data(i, 2))
            If Evaluate("ISREF('" & Data(i, 2) & "'!A1)") = False Then Sheets.Add(, Sheets(Sheets.Count)).Name = Sht
            .Columns("A:B").Copy
            With Sheets("" & Sht & "")
                '.UsedRange.Delete ' ! If recurring code execution...Uncomment this snippet
                .Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteAll
                .Columns.AutoFit
                .UsedRange.Borders.Weight = 2
            End With
            .AutoFilter
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

[Marc L]

According to your attachment a VBA demonstration as a beginner starter to paste to the Sheet13 (Sheet1) worksheet module :

Sub Demo1()
        Dim V, W, S$
        Application.ScreenUpdating = False
    With [A1].CurrentRegion
           .Columns(2).AdvancedFilter 2, , [K1], True
            V = [K1].CurrentRegion.Rows.Count - 1
            V = Application.Small([K2].Resize(V).Value2, Evaluate("ROW(1:" & V & ")"))
        For Each W In V
            [K2].Value2 = W:  S = Format$(W, "mm-dd-yyyy")
            If Evaluate("ISREF('" & S & "'!A1)") Then Sheets(S).UsedRange.Clear Else Sheets.Add(, Sheets(Sheets.Count)).Name = S
           .AdvancedFilter 2, [K1:K2], Sheets(S).[A1]
        Next
    End With
        [K1].CurrentRegion.Clear
        Application.ScreenUpdating = True
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[dburge07]

Both solutions work great. One question for Marc L --- How can I get this to copy and paste the entire row. My sample sheet didnt have the 6 other columns with data included and I need to include that data in the new sheet along with the filtered result

[Marc L]

It's what happens when the attachment does not well reflect the real workbook …
My demonstration copies all the contiguous data so not a concern if there is no blank column between data,
but in case of non contiguous data you may use Resize or UsedRange statement …

[dburge07]

Yes that's absolutely 100% my fault for not uploading an accurate portrayal of the data. Thank you for taking the time to help, Marc. Appreciate it.

[dburge07]

I just need it to bring the information in columns A, B, & D to the new workbook it creates based on the date. There will be no blank rows in the date column, I am looking for/correcting for that prior to running this routine.

[Marc L]

I just need it to bring the information in columns A, B, & D to the new workbook it creates based on the date.

If still in need attach the source workbook and the expected result 'new workbook' accordingly …

[Sintek]

For my code...
Change

.Columns("A:B").Copy

to

Union(.Columns("A:B"), .Columns("D:D")).copy

[dangelor]

Another possibility...

Sub Test()
    Dim rg As Range, s As Variant, k As Variant

    Set rg = Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Resize(, 4)
    With CreateObject("Scripting.Dictionary")
        For Each s In Application.Index(Application.Transpose(rg.Columns(2).Value), 1, 0)
            If s <> "ONDATE" Then .Item(s) = Empty
        Next s
        For Each k In .keys
            rg.AutoFilter 2, k
            rg.SpecialCells(xlCellTypeVisible).Copy
            Worksheets.Add
            With ActiveSheet
                .Name = Replace(k, "/", "-")
                .Cells(1, 1).PasteSpecial
                .Columns.AutoFit
            End With
            rg.AutoFilter
        Next k
    End With
End Sub

[dburge07]

Works perfectly.

All 3 solutions = great. Thanks a ton!

[Sintek]

......................
Thanks.png