VBA to move data to new worksheets based on cell value

Try on a copy of your file:

Sub CreateSheet()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    bottomA = Sheets("Supply Data").Range("A" & Rows.Count).End(xlUp).Row
    Dim branch As Range
    Dim ws As Worksheet
    Dim rngUniques As Range
    Sheets("Supply Data").Range("A1:A" & bottomA).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("A1:A" & bottomA), Unique:=True
    Set rngUniques = Sheets("Supply Data").Range("A2:A" & bottomA).SpecialCells(xlCellTypeVisible)
    If Sheets("Supply Data").AutoFilterMode = True Then Sheets("Supply Data").AutoFilterMode = False
    For Each branch In rngUniques
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(branch.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = branch.Value
            Sheets("Supply Data").Range("A1:A" & bottomA).AutoFilter Field:=1, Criteria1:=branch
            Sheets("Supply Data").Range("A1:A" & bottomA).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(branch.Value).Cells(Sheets(branch.Value).Rows.Count, "A").End(xlUp).Offset(1, 0)
            Sheets(branch.Value).Rows(1).EntireRow.Delete
            Sheets(branch.Value).Columns.AutoFit
            If Sheets("Supply Data").AutoFilterMode = True Then Sheets("Supply Data").AutoFilterMode = False
        End If
    Next branch
    Application.DisplayAlerts = False
    Sheets("Supply Data").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 End Sub

You are very welcome and thanks for the rep.