Sub AddSheetsMonth()
Const ProcTitle As String = "Add Sheets Month"
Const swsName As String = "Sheet1" 'Name Sheet
Const sCol As Long = 12
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Source Range
Dim srCount As Long: srCount = srg.Rows.Count ' Source Rows Count
If srCount < 2 Then Exit Sub ' just headers or no data at all
Dim sData As Variant: sData = srg.Columns(sCol).Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dKey As Variant
Dim dString As String
Dim r As Long
' Write the unique strings to a dictionary.
For r = 2 To srCount
dKey = sData(r, 1)
If Not IsError(dKey) Then
If Len(dKey) > 0 Then
dString = CStr(dKey)
If StrComp(dString, swsName, vbTextCompare) <> 0 Then
dict(dString) = Empty
End If
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only blanks and error values and whatnot
Erase sData
Application.ScreenUpdating = False
Dim scrg As Range ' Source Copy Range
Dim dws As Object
Dim dwsName As String
For Each dKey In dict.Keys
' Restrict to maximum allowed characters (31).
dwsName = dKey
If Len(dwsName) > 9 Then
dwsName = Left(dwsName, 9)
Debug.Print "'" & dKey & "' is too long." & vbLf _
& "'" & dwsName & "' is used in the continuation." ' log
End If
' Delete possibly existing sheet.
On Error Resume Next
Set dws = wb.Sheets(dwsName)
On Error GoTo 0
If Not dws Is Nothing Then ' destination sheet exists
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
'Else ' destination sheet doesn't exist
End If
' Create a reference to a newly added (destination) worksheet.
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Rename Destination Worksheet.
On Error Resume Next
dws.Name = dwsName
If Err.Number <> 0 Then ' invalid sheet name
' log
Debug.Print "'" & dwsName & "' cannot be used as a sheet name."
'Else ' valid sheet name
End If
On Error GoTo 0
' Create a reference to the Source Copy Range.
srg.AutoFilter sCol, dKey
Set scrg = srg.SpecialCells(xlCellTypeVisible) ' headers are visible
sws.AutoFilterMode = False
' Copy the Source Copy Range to the Destination Worksheet.
scrg.Copy dws.Range(dFirstCellAddress)
With dws
.UsedRange.EntireColumn.AutoFit
End With
' Initialize Destination Worksheet variable (reference).
Set dws = Nothing
Next dKey
sws.Activate
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, ProcTitle
End Sub
