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

Dang, ok. I'll write it up again. It's super quick because it uses sort instead of filtering. I have some assumptions regarding the ranges, so while I'm writing this up, if you could describe your data structure Bala, that would help. Or post a sample file.

Did anyone see my other post? It was a fairly long piece of code. I posted it a couple hours ago. I'm not going to be happy if it's actually lost, spent a good chunk of time on it.

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

Here is sample code to filter values on Sheet1 by a person's name.  In this example the names are Matt, John and Jared....  If you paste this code into the attached workbook and change the SaveAs file path you should be able to get close to what you want:

 Sub CreateMultipleWBs()
 
    Dim arrFilter As Variant
 
    arrFilter = Array("Matt", "John", "Jared") 'Define Array

    'Arrays start at 0 so if we have 3 elements then we need to go from 0 - 2
    For intLp = 0 To 2
       With Sheets("Sheet1")
         lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'Define last column
         lrow = .Cells(Rows.Count, "A").End(xlUp).Row 'Define last row
                .AutoFilterMode = False 'UnFilter Data from previous...
             With .Range(Cells(1, 1), Cells(lrow, lCol))
                 .AutoFilter 1, "=" & arrFilter(intLp)  'Filter X Name (i.e. Matt, John, Jared)  1 = Column A or Column #1
                 .SpecialCells(xlCellTypeVisible).Copy 'Delete Everything but the header... offset resizes range
             End With
             
             Workbooks.Add 'Add Workbook
             Range("A1").PasteSpecial 'Paste Data
             ActiveWorkbook.SaveAs Filename:="C:\Users\mmickle1\Desktop\" & arrFilter(intLp) & ".xlsx" 'Save File
             ActiveWorkbook.Close 'Close new workbook

         End With
    Next intLp 'Go to next value to filter in our array
    
 End Sub

Hi Bala Subramanian,

We can do this by creating macro.

Can you give sample file so that i can explain how to do.

Or explain in detail.