VBA macro which filters and splits dataset into new workbooks

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.Sheets("SheetA").Copy After:=wb.Sheets(1) wb.Sheets("SheetA").Visible = xlSheetHidden ThisWorkbook.Sheets("SheetB").Copy After:=wb.Sheets(1) 'end new code' wb.Protect Password:="password", Structure:=True, Windows:=True filePath = "C:\...\" newFileName = rng & "filename.xlsm" ActiveWorkbook.SaveAs _ Filename:=filePath & newFileName, _ FileFormat:=xlOpenXMLWorkbookMacroEnabled newBookNames.Add newFileName Next rng ThisWorkbook.Sheets("temp").Delete End With ' This might take a while because everything will re-calculate Application.Calculation = xlCalculationAutomatic ' Now loop through the new book names ' and save each workbook For Each bookName In newBookNames Workbooks(CStr(bookName)).Save Workbooks(CStr(bookName)).Close False Next bookName Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub