This VBA macro uses a worksheet (source\_data\_worksheet) to filter and split out the records based on about a dozen unique column (D) values in a dataset of about to separate workbooks which are saved to a folder.

There are over 10,000 records x 18 columns total with text and numbers (the overall file size of source worksheet is about 1.3MB). The number of records per unique value of filtering variable range from over 100 to over 5000. The source dataset is sorted by the variable used for filtering/splitting out. 

In addition to creating the worksheet in the new workbook with the filtered subset of the data, the macro also copies two worksheets from the source workbook to the destination workbook next to the newly output subset worksheet.

One of the worksheets is very simple/small (SheetA), but another one (SheetB) has a table of about 100 rows by 9 columns which are using `VLOOKUP` and `INDIRECT` functions to cross-reference in data from the newly created subset worksheet based on some criteria.

The macros works and the data is populated as expected. It starts out fairly quick with the first subset (about 300 rows) populating in a few seconds.

However, **things slow down substantially (10 minutes or longer for some of the larger subsets)** and the number of output records itself does not seem proportionate to the longer time duration. The macro also seems to tax the system a lot as it *nearly* locks up Excel so that it's best to save and close all other worksheets before it runs. I am wondering if there is something in the code that reduces efficiency and causes undue system load during execution.

The output file formal is .xlsm (as opposed to .xlsx default) because some of the copied worksheets contain worksheet-level VBA that needs to be preserved in the new output files.

System: Office Pro 2010, 32-bit running on 64-bit Win i5 3Ghz 8GB.

```
    Option Explicit

Sub Create_by_keyrecord()

Dim r As Long, rng As Range, ws As Worksheet, wb As Workbook

Dim lastRow As Integer

Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Sheets("Sheet1")
    Sheets.Add().Name = "temp"
    .Range("D7", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("D7"), Unique:=True
     For Each rng In Sheets("temp").Range("D7", Sheets("temp").Range("D7").End(xlDown))
        .AutoFilterMode = False
        .Range("D7").AutoFilter Field:=3, Criteria1:=rng
        Set ws = Sheets.Add

        lastRow = .Range("B7:I7").End(xlDown).Row
        .Range("B7:S" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        ws.Range("B7").PasteSpecial xlPasteColumnWidths
        ws.Range("B7").PasteSpecial xlPasteAll
        .Range("B2:S6").Copy ws.Range("B2")
        Columns("A:A").ColumnWidth = 1

        For r = 1 To lastRow
            ws.Rows(r).RowHeight = .Rows(r).RowHeight
        Next r

        'ws.Name = rng
        ws.Name = "source_data_worksheet"
        ws.Move
        .AutoFilterMode = False
        Rows.Hidden = False
        Columns.Hidden = False
        ActiveWindow.DisplayGridlines = False
        Range("G7").Select
    ActiveWindow.FreezePanes = True

    Range("B6:S6").AutoFilter

'copy additional worksheets to new workbook
    Set wb = ActiveWorkbook
        Windows("sourseworksheet.xlsm").Activate
        Sheets("SheetA").Select
        Sheets("SheetA").Copy After:=wb.Sheets(1)
        wb.Sheets("SheetA").Visible = xlSheetHidden

        Windows("sourseworksheet.xlsm").Activate
        Sheets("SheetB").Select
        Sheets("SheetB").Copy After:=wb.Sheets(1)
'end new code'

        ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=True

        ActiveWorkbook.SaveAs _
        Filename:="C:\...\" & rng & "filename.xlsm ", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled

        ActiveWorkbook.Close 'SaveChanges:=True

    Next rng
      Sheets("temp").Delete

End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

```