Sorting Data on to sub worksheet by date

[Newbienew]

So I am looking to sort data on one specific sheet to other sheets by the date. I watch a video on it on youtube but it seemed to be a lot. This was the title of the video "Spreadsheets: How to Sort Data Onto Sub Sheets". I was hoping there might be a better way to do this or achieve this goal. I will have a total of 12 months and one sheet for historic data. I thank you for your help in advance[/COLOR]

 

[Logit]

.
Here is the updated code. The additional macro first deletes all sheets except for the sheet named MAIN.
Then it proceeds to create the different sheets and transfer the data.

The sheets are created based on the dates listed in Col D. If a row of data has a blank cell in the D Col .... that information will not be transferred to
a newly created sheet. You will want to be certain all data rows have a date in Col D, if you want that row of data transferred to a newly created sheet.

Option Explicit


Sub DeleteSheets1()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.Name <> "Main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    CreateSheets
    
End Sub


Sub CreateSheets()




    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet




        Set RngBeg = Worksheets("Main").Range("D2")
        Set RngEnd = Worksheets("Main").Cells(Rows.Count, "D").End(xlUp)




        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Main").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]mmm;@"))




                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]mmm;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True


MakeHeaders


End Sub




Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Main"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
    Columns("A:Q").EntireColumn.AutoFit
Next


Application.ScreenUpdating = True


CopyData


End Sub




Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Main").Cells(Rows.Count, "D").End(xlUp).Row
Dim ans As String
Dim ans2 As String




NoVisi




    For i = 2 To Lastrow
    ans = Sheets("Main").Cells(i, 4).Value
    ans2 = Format(ans, "[$-409]mmm;@")
        Sheets("Main").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
    
Visi




Application.ScreenUpdating = True




Sheets("Main").Activate
Sheets("Main").Range("A1").Select




Exit Sub




Application.ScreenUpdating = True




End Sub




Sub NoVisi()
Dim CommandButton1 As Object




CommandButton1.Visible = False




End Sub




Sub Visi()
Dim CommandButton1 As Object




CommandButton1.Visible = True
End Sub

 

[Newbienew]

You are awesome Good Sir. I will put this marco to very good use

 

[Logit]

.
Glad to help. You are welcome.

 

[Newbienew]

I may return lol, but you are incredible

 

[Logit]

.
Naw .. just a lowly peasant with some knowledge of VBA attempting to assist others because others assisted me when
I first started.

But I thank you for the kind words.

Cheers.