Macro in excel sheet 2010

Ok, here is the code I used. The initial ranges are assumed and could just as easily be made dynamic. It should work pretty fast.

The big assumption here, besides the range of data being used, is:

• There are two empty columns directly to the right of the data set specified
• Headers are in row 1
• Data starts in row 2
• Entity values are in the first column of the data set

Sub CreateFilesFromUniqueValues()

    Dim EntityBook As Workbook
    Dim Book As Workbook
    Dim EntitySheet As Worksheet
    Dim Sheet As Worksheet
    Dim Entities As New Collection
    Dim CriteriaRange As Range
    Dim FilterRange As Range
    Dim FoundRange As Range
    Dim SortRange As Range
    Dim WholeRange As Range
    Dim EntityExists As Boolean
    Dim Index As Long
    Dim LastColumn As Long
    Dim EntityFullname As String
    Dim EntityName As String
    Dim EntityPath As String
    Dim Entity As Variant
    Dim Values As Variant

    Set Book = ThisWorkbook    ' assumed
    Set Sheet = Book.ActiveSheet    ' assumed
    Set FilterRange = Sheet.Range("A2:B22")    ' assumed, could be dynamic
    Values = FilterRange.Columns(1).Value    ' assumed
    LastColumn = FilterRange(1, 1).Column + FilterRange.Columns.Count  ' assumed no data to the right of the range

    For Index = LBound(Values, 1) To UBound(Values, 1)
        If Not InCollection(Entities, CStr(Values(Index, 1))) Then
            Entities.Add CStr(Values(Index, 1)), CStr(Values(Index, 1))
        End If
    Next Index

    EntityPath = Book.Path    ' assumed

    Set SortRange = FilterRange.Columns(1).Offset(, FilterRange.Columns.Count)
    Set CriteriaRange = SortRange.Offset(, 1)
    Set WholeRange = FilterRange.Columns(1).Resize(, FilterRange.Columns.Count + 2)

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    SortRange.Cells(1, 1).Offset(-1, 0).Value = "_Sort"
    CriteriaRange.Cells(1, 1).Offset(-1, 0).Value = "_Criteria"

    SortRange.Formula = "=ROW(A1)"
    SortRange.Value = SortRange.Value

    For Each Entity In Entities

        EntityName = Entity & ".xlsx"
        EntityFullname = EntityPath & Application.PathSeparator & EntityName

        CriteriaRange.Formula = "=1/(" & FilterRange.Cells(1, 1).Address(0, 0) & "=" & Chr(34) & Entity & Chr(34) & ")"
        CriteriaRange.Value = CriteriaRange.Value

        WholeRange.Sort Key1:=CriteriaRange.Cells(1, 1), Order1:=xlAscending, Header:=xlNo

        On Error Resume Next
        Set FoundRange = Intersect(CriteriaRange.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, FilterRange.EntireColumn)
        On Error GoTo 0

        If Not FoundRange Is Nothing Then

            Set EntityBook = Workbooks.Add(xlWBATWorksheet)
            Set EntitySheet = EntityBook.Worksheets(1)
            
            FilterRange.Rows(1).Offset(-1).Copy EntitySheet.Range("A1")
            FoundRange.Copy EntitySheet.Range("A2")
            
            EntityExists = True
            If Dir(EntityFullname, vbNormal) <> vbNullString Then
                On Error Resume Next
                Kill EntityFullname
                On Error GoTo 0
                EntityExists = CBool(Dir(EntityFullname, vbNormal) <> vbNullString)
            Else
                EntityExists = False
            End If

            If Not EntityExists Then
                EntityBook.SaveAs EntityFullname
                EntityBook.Close
            End If

        End If

    Next Entity

    WholeRange.Sort Key1:=SortRange.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
    SortRange.Cells(1, 1).Offset(-1, 0).Resize(SortRange.Rows.Count + 1).ClearContents
    CriteriaRange.Cells(1, 1).Offset(-1, 0).Resize(CriteriaRange.Rows.Count + 1).ClearContents

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Public Function GetCleanFileName( _
       ByVal FileName As String _
       ) As String

' Return the clean version of the proposed file name by replacing illegal characters with legal
' alternatives.

    FileName = Replace(FileName, "\", "-")
    FileName = Replace(FileName, "/", "-")
    FileName = Replace(FileName, ":", "-")
    FileName = Replace(FileName, "*", "-")
    FileName = Replace(FileName, """", "'")
    FileName = Replace(FileName, "<", "(")
    FileName = Replace(FileName, ">", ")")
    FileName = Replace(FileName, "|", "-")

    GetCleanFileName = FileName

End Function


Public Function InCollection( _
       ByVal Collection As Collection, _
       ByVal Key As String _
       ) As Boolean

' Returns True if the specified key is found in the specified collection.

    On Error Resume Next
    InCollection = CBool(Not IsEmpty(Collection(Key)))
    On Error GoTo 0

End Function