Macro in excel sheet 2010

Hi there,

This is a typical request. There are several ways you can do this. Personally I don't like the filter method because it's really slow - at least compared to sorting, which is lightning fast. As such, I'll use a couple helper columns.

The below code makes some assumptions about your data. I used some dummy data on the active sheet, headers in row 1, data starting in row 2 and going to row 22, only in columns A and B. There are a few places where this could be made dynamic, as commented in the code, but we would need to know more about your data structure to do so. Basically what it's doing is using a first helper column to keep the original sort for the data. Then it uses a secondary column to sort values you would normally filter by, then gets those rows of data and puts it into a new file. The file is saved to the same directory the file it's run from is in. The name is the value of the unique entry, in this example code it's the value from column A.

Option Explicit


Sub CreateNewFiles()

    Dim Book As Workbook
    Dim EntryBook As Workbook
    Dim Sheet As Worksheet
    Dim EntrySheet As Worksheet
    Dim Entries As New Collection
    Dim CriteriaRange As Range
    Dim DataRange As Range
    Dim FilterRange As Range
    Dim SortRange As Range
    Dim WholeRange As Range
    Dim EntryExists As Boolean
    Dim Index As Long
    Dim LastColumn As Long
    Dim EntryFullname As String
    Dim EntryName As String
    Dim EntryPath As String
    Dim Entry As Variant
    Dim Values As Variant

    Set Book = ThisWorkbook
    Set Sheet = Book.ActiveSheet

    Set DataRange = Sheet.Range("A2:B22")    'could be dynamic
    LastColumn = 3    'could be dynamic

    Values = DataRange.Value

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

    Set SortRange = Sheet.Range("C2:C22")    'could be dynamic
    Set CriteriaRange = Sheet.Range("D2:D22")    'could be dynamic
    Set WholeRange = DataRange.Resize(, DataRange.Columns.Count + 2)

    SortRange(1, 1).Offset(-1, 0).Value = "Sort"
    CriteriaRange(1, 1).Offset(-1, 0).Value = "Criteria"
    SortRange.Formula = "=ROW(A1)"
    SortRange.Value = SortRange.Value

    EntryPath = Book.Path & Application.PathSeparator

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

    For Each Entry In Entries

        EntryFullname = EntryPath & Entry & ".xlsx"

        CriteriaRange.Formula = "=1/(A2=" & Chr(34) & Entry & Chr(34) & ")"
        CriteriaRange.Value = CriteriaRange.Value

        WholeRange.Sort CriteriaRange(1, 1), xlAscending, Header:=xlNo
        On Error Resume Next
        Set FilterRange = Intersect(CriteriaRange.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, DataRange.EntireColumn)
        On Error GoTo 0

        If Not FilterRange Is Nothing Then

            Set EntryBook = Workbooks.Add(xlWBATWorksheet)
            Set EntrySheet = EntryBook.Worksheets(1)

            DataRange(1, 1).Offset(-1, 0).Resize(, DataRange.Columns.Count).Copy EntrySheet.Range("A1")
            FilterRange.Copy EntrySheet.Range("A2")
            Application.CutCopyMode = False

            EntryExists = True
            If Dir(EntryFullname, vbNormal) <> vbNullString Then
                On Error Resume Next
                Kill EntryFullname
                On Error GoTo 0
                EntryExists = CBool(Dir(EntryFullname, vbNormal) <> vbNullString)
            ElseIf Book.Path <> vbNullString Then
                EntryExists = False
            End If

            If Not EntryExists And Not EntryBook Is Nothing Then
                EntryBook.SaveAs EntryFullname
                EntryBook.Close
            End If

            Set FilterRange = Nothing

        End If

    Next Entry

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

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

End Sub


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