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
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