Sub SplitDataByMonth()
Dim ws As Worksheet
Dim sourceData As Range
Dim cell As Range
Dim destSheet As Worksheet
Dim currentMonth As String
Dim filterCriteria As String
' Set the source worksheet and data range
Set ws = ThisWorkbook.Worksheets("WTD") ' Change to your source worksheet name
Set sourceData = ws.Range("A1:C" & ws.Cells(Rows.Count, 1).End(xlUp).Row) '
Assuming data starts from row 1
' Loop through each unique month in the source data
For Each cell In sourceData.Columns(1).Cells
currentMonth = cell.Value ' Month name is in column A
' Create a filter criteria to extract rows for the current month
filterCriteria = ws.Cells(cell.Row, 1).Address(0, 0) & "=""" & currentMonth
& """"
' Apply filter and copy filtered data to a new sheet
sourceData.AutoFilter Field:=1, Criteria1:=currentMonth
On Error Resume Next
Set destSheet =
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
destSheet.Name = currentMonth
sourceData.SpecialCells(xlCellTypeVisible).Copy destSheet.Cells(1, 1)
sourceData.AutoFilter
On Error GoTo 0
Next cell
Call DeleteSheetsWithPattern
End Sub
Sub DeleteSheetsWithPattern()
Dim ws As Worksheet
Dim i As Long
Application.DisplayAlerts = False ' Turn off alerts to avoid confirmation
For i = ThisWorkbook.Sheets.Count To 1 Step -1
Set ws = ThisWorkbook.Sheets(i)
If Left(ws.Name, 5) = "Sheet" Then ' Adjust the pattern as needed
ws.Delete
End If
Next i
Application.DisplayAlerts = True ' Turn alerts back on
End Sub
