Excel VBA - separate data on 'Month' worksheet onto new worksheets for each unique name in column H

' This solution assumes that:

    ' 1. You have Excel 2021/Microsoft 365 so your version of Excel includes the FILTER, SORT and UNIQUE functions.

    ' 2. There are no other worksheets in your workbook except the first, named 'Month'.

    ' 3. Neither the 'Month' worksheet, nor the structure of the workbook itself, are protected.

' Demo workbook available to download at: https://drive.google.com/file/d/16T16RLWx2vNsyIArDGJ1-ft2iY8VOiE2/view?usp=sharing

' ============
' Setup steps:
' ============

' 1. In the Project Explorer in the VB Editor, expand the Microsoft Excel Objects section, select the ThisWorkbook object, then in the Properties Window, change the 'Name' property to 'wbThis'.

' 2. In the Project Explorer in the VB Editor, expand the Microsoft Excel Objects section, select the Sheet1 object, then in the Properties Window, change the 'Name' property to 'wsMonth'.

' 3. Select the cells on row 1 of your 'Month' worksheet which contain your column headers - in the example workbook, that is the range A1:J1.

' 4. Type 'DataHeaders' into the Name box (in the top left of the Excel screen, just under the ribbon menu), and press Enter. This defines a named range for those cells.

' 5. Choose the Formulas section of the ribbon menu, and click Define Name. In the dialog box that is displayed enter:

    ' Name:     UniqueNames
    ' Scope:        Workbook
    ' Refers To:    =IF(NOT(ISBLANK(Month!$H$2)),SORT(UNIQUE((Month!$H$2:INDEX(Month!$H$2:$H$1001,COUNTA(Month!$H$2:$H$1001),0)))),"No data")

    ' ...and click OK.

' 6. Right-click anywhere in the tree structure under your workbook's VBAProject in the Project Explorer, then choose Insert > Module.

' 7. With the new module selected in the Project Explorer, in the Properties window, change the 'Name' property to 'modDataManagement.

' 8. Add 2 more code modules in this same way, and change their names to modPublicFunctions and modUtilities respectively.

' 9. Paste the code for the three VBA modules listed below into the three code modules you've created in your VBA project.

' 10. In the VB Editor, ensure that under View > Toolbars, the Debug option is ticked; if it isn't, tick it.

' 11. Then under the Debug menu, click Compile VBAProject.

    ' If nothing seems to happen, that's good - the VBA project compiled successfully.
    ' If an error is displayed, you've made an error/typo in the code you put into the modules.

' 12. Assuming that you have the Developer menu visible in the ribbon menu, select it, then in the 'Controls' group, click the 'Insert' dropdown, and in the 'Form Controls' section, click the small white rectangle (hovering the mouse over it will pop up 'Button (Form Control)').

' 13. Hold down the Alt key, and click-and-drag the crosshair mouse pointer over some blank cells to the top-right of your source data on the 'Month' worksheet. This will create a clickable button on the worksheet.

' 14. The 'Assign Macro' dialog box will then appear - make sure 'Macros in' is set to 'This Workbook', and select 'SeparateDataToSheets' from the list, then click OK.

' =================
' modDataManagement
' =================

Option Explicit

Public Sub SeparateDataToSheets()

    Application.EnableCancelKey = xlDisabled

    Dim wsEachDataSheet As Worksheet
    Dim rngUniqueNames As Range, rngColumnHeaders As Range, rngDataFilteredByName As Range
    Dim arrUniqueNames As Variant, arrDataForEachName As Variant
    Dim i As Integer
    Dim strNoDataMsg As String, strNoDataMsg_Title As String, _
        strFilterFormula As String
    Dim lngNoDataMsg_Style As VbMsgBoxStyle

    ' Remove all previous data sheets from previous runs
    Call RemoveDataSheets

    ' Initialise MsgBox variables
    strNoDataMsg_Title = "No data found"
    strNoDataMsg = "There are no data records to separate onto worksheets by name."
    lngNoDataMsg_Style = vbInformation + vbOKOnly

    ' Choose cell in which to calculate dynamic range
    With wsMonth

        Set rngUniqueNames = .Range("A" & .Rows.Count).End(xlUp).Offset(RowOffset:=2)

    End With

    ' Avoid screen flicker
    Application.ScreenUpdating = False

    ' Calculate dynamic range
    rngUniqueNames.Formula2 = "=UniqueNames"

    ' If no unique names found, notify user
    If rngUniqueNames.Value2 = "No data" Then

        MsgBox strNoDataMsg, lngNoDataMsg_Style, strNoDataMsg_Title

    Else

        ' Check whether evaluation of dynamic range resulted in a spilled range
        If rngUniqueNames.HasSpill Then

            ' Populate the array of unique names from the spilled range
            arrUniqueNames = rngUniqueNames.SpillingToRange.Value2

        Else

            ' Populate the array with the single unique name
            ReDim arrUniqueNames(1 To 1, 1 To 1)
            arrUniqueNames(1, 1) = rngUniqueNames.Value2

        End If

        ' Convert the 2D array into a 1D array
        arrUniqueNames = GetInnerDimensionOnly(arrUniqueNames)

        ' Unique names now captured in array, dynamic array cell no longer required
        rngUniqueNames.ClearContents

        ' Iterate over array of unique names
        For i = LBound(arrUniqueNames) To UBound(arrUniqueNames)

            Set wsEachDataSheet = Nothing
            With wbThis

                If Not WorksheetExists(arrUniqueNames(i)) Then

                    ' Add a worksheet with the unique name
                    Set wsEachDataSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))

                    ' Ensure name does not exceed max sheet name length
                    If Len(arrUniqueNames(i)) >= 32 Then

                        wsEachDataSheet.Name = Left$(arrUniqueNames(i), 32)

                    Else

                        wsEachDataSheet.Name = arrUniqueNames(i)

                    End If

                Else

                    ' Use existing worksheet with this unique name
                    Set wsEachDataSheet = .Worksheets(arrUniqueNames(i))

                End If

            End With

            With wbThis.Names("DataHeaders").RefersToRange

                ' Copy column headers to data sheet
                Set rngColumnHeaders = wsEachDataSheet.Range(.Address)
                rngColumnHeaders.Value2 = .Value2
                rngColumnHeaders.Font.Bold = True

            End With

            With wsMonth

                ' Choose cell in which to calculate filtered data
                Set rngDataFilteredByName = .Range("C" & .Rows.Count).End(xlUp).Offset(RowOffset:=2)

                ' Build the FILTER formula
                strFilterFormula = "=FILTER("
                strFilterFormula = strFilterFormula & .Range("A1").CurrentRegion.Offset(RowOffset:=1).Resize(RowSize:=.Range("A1").CurrentRegion.Rows.Count - 1).Address(RowAbsolute:=True, ColumnAbsolute:=True)
                strFilterFormula = strFilterFormula & "," & .Range("$H$2:$H$" & .Range("H" & .Rows.Count).End(xlUp).Row).Address(RowAbsolute:=True, ColumnAbsolute:=True)
                strFilterFormula = strFilterFormula & "=""" & arrUniqueNames(i) & ""","""")"
                rngDataFilteredByName.Formula2 = strFilterFormula

            End With

            If rngDataFilteredByName.HasSpill Then

                ' Remove any existing filtered data
                With wsEachDataSheet.Range("A2").CurrentRegion
                    .Offset(RowOffset:=1).Resize(RowSize:=.Rows.Count - 1).ClearContents
                End With

                ' Copy filtered data to sheet for this name
                With rngDataFilteredByName

                    wsEachDataSheet.Range("A2").Resize( _
                        RowSize:=.SpillingToRange.Rows.Count, _
                        ColumnSize:=.SpillingToRange.Columns.Count) _
                            .Value2 = .SpillingToRange.Value2

                End With

            End If

            ' Reset the cell used to calculate the filtered data
            rngDataFilteredByName.ClearContents

            ' Apply text alignment, borders and auto column widths
            With wsEachDataSheet.UsedRange
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .EntireColumn.AutoFit
            End With

        Next i

    End If

    Application.ScreenUpdating = True

    ' Memory management / assist garbage collection
    If Not rngUniqueNames Is Nothing Then Set rngUniqueNames = Nothing
    If Not rngColumnHeaders Is Nothing Then Set rngColumnHeaders = Nothing
    If Not rngDataFilteredByName Is Nothing Then Set rngDataFilteredByName = Nothing
    If Not wsEachDataSheet Is Nothing Then Set wsEachDataSheet = Nothing
    If ArrayInitialized(arrUniqueNames) Then Erase arrUniqueNames
    If ArrayInitialized(arrDataForEachName) Then Erase arrDataForEachName

End Sub

' ==================
' modPublicFunctions
' ==================

Option Explicit
Option Private Module

Public Function WorksheetExists(ByVal strSheetName As String) As Boolean

    Application.EnableCancelKey = xlDisabled

    Dim wsCheck As Worksheet

    On Error Resume Next
    Set wsCheck = wbThis.Worksheets(strSheetName)
    On Error GoTo 0

    WorksheetExists = Not wsCheck Is Nothing

    ' Memory management / assist garbage collection
    If Not wsCheck Is Nothing Then Set wsCheck = Nothing

End Function

Public Function GetInnerDimensionOnly(ByRef arrConvert As Variant) As Variant()

    With Application

        .EnableCancelKey = xlDisabled

        Dim blHasSecondDimension As Boolean
        Dim arrReturn() As Variant

        On Error Resume Next
        blHasSecondDimension = CBool(UBound(arrConvert, 2) > -1)
        On Error GoTo 0

        If blHasSecondDimension Then

            arrReturn = .Transpose(.Index(arrConvert, 0, 1))
            GetInnerDimensionOnly = arrReturn

        End If

    End With

End Function

Public Function ArrayInitialized(arrTest As Variant) As Boolean

    Application.EnableCancelKey = xlDisabled

    On Error Resume Next
    ArrayInitialized = LBound(arrTest) <= UBound(arrTest)
    On Error GoTo 0

End Function

' ============
' modUtilities
' ============

Option Explicit
Option Private Module

Public Sub RemoveDataSheets()

    With Application
        .EnableCancelKey = xlDisabled
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Dim wsEach As Worksheet

    For Each wsEach In wbThis.Worksheets

        If wsEach.Name <> wsMonth.Name Then wsEach.Delete

    Next wsEach

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub