VBA macro which filters and splits dataset into new workbooks

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 I

I agree with @RubberDuck about the RowHeight issue. There are a couple ways to look at this.

Look at the Help in VBA for this:


If you return the RowHeight property of several rows, you will either get the row height of each of the rows (if all the rows are the same height) or null (if they’re different heights).

So you can either write code to test if the RowHeight of your source = a number and then set the new sheet to the same value knowing that they are all the same. This is a bit fiddly maybe if you are new to VBA.

The other answer is to copy the EntireRow from your filtered data which will then copy the RowHeight for you. Is there anything beyond column S which you don't want copied? If not, then let's copy the entire row. It might even be quicker to copy the entire row and then Clear columns T:whatever.

Another point is that you are not touching Application.Calculation but you have a sheet that uses the INDIRECT function and you are doing a lot of filtering. I suspect this is the biggest issue. That function is Volatile which means Excel recalculates it even if it doesn't need to. This is because Excel cannot track which cells feed the function.

I suggest that you set Application.Calculation = xlCalculationManual at the top of your code (like you do with ScreenUpdating) and then set it to Application.Calculation = xlCalculationAutomatic at the end. It is a good idea to store the original value before setting it to xlCalculationManual and then you can use that value to restore it. Here's the code:

Dim xlCalc As XlCalculation

' Save the original setting
xlCalc = Application.Calculation
' Put calcs to manual
Application.Calculation = xlCalculationManual
'
' ... do some intensive work
'

' Put calcs back to original setting
Application.Calculation = xlCalc

When you save a workbook with calculations set to xlCalculationManual the workbook remembers the setting which can then cause problems when you re-open the workbook because it doesn't re-calculate itself. So we should somehow keep track of your new workbooks, keep them open and save & close them after putting calculations back to their original setting. We can use the Collection object for this.

I've added some references to ThisWorkbook so that the code is referring to the correct workbook. Change these to Workbooks("book_name.xlsm") if it is not the workbook that is running the code.

This is what I think the changed code looks like. This includes copying the EntireRow so you'll need to revert back to your code if this doesn't fit your requirements. WARNING: I cannot be sure it will work correctly for your data, so use F8 to step through it and test it thoroughly.

```
Sub Create_by_keyrecord()

Dim r As Long, rng As Range, ws As Worksheet, wb As Workbook
Dim xlCalc As XlCalculation
Dim newBookNames As Collection
Dim bookName As Variant
Dim filePath As String
Dim newFileName As String
Dim lastRow As Integer

Application.DisplayAlerts = False
Application.ScreenUpdating = False

' Save the original setting
xlCalc = Application.Calculation
' Put calcs to manual
Application.Calculation = xlCalculationManual

Set newBookNames = New Collection

With ThisWorkbook.Sheets("Sheet1")
ThisWorkbook.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 = ThisWorkbook.Sheets.Add

lastRow = .Range("B7:I7").End(xlDown).Row
.Range("B7:S" & lastRow).EntireRow.SpecialCells(xlCellTypeVisible).Copy
ws.Range("A7").PasteSpecial xlPasteColumnWidths
ws.Range("A7").PasteSpecial xlPasteAll
.Range("B2:S6").EntireRow.Copy ws.Range("A2")

' Maybe empty column A?
ws.Columns("A:A").ClearContents

ws.Columns("A:A").ColumnWidth = 1

ws.Name = "source_data_worksheet"
' Create the new workbook using a Workbook object variable
' It means we already have a reference to the new workbook later
' in the code
Set wb = Workbooks.Add
ws.Move Before:=wb.Worksheets(1)
Set ws = wb.Worksheets(1)
.AutoFilterMode = False
' Which workbook/sheet are these lines of code for?
Rows.Hidden = False
Columns.Hidden = False

' Make sure the new book & sheet are active
wb.Activate
ws.Activate
ActiveWindow.DisplayGridlines = False
ws.Range("G7").Select
ActiveWindow.FreezePanes = True

ws.Range("B6:S6").AutoFilter

'copy additional worksheets to new workbook
ThisWorkbook.

StackExchange Code Review Q#101474, answer score: 5