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 &amp; 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" &amp; 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" &amp; 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 &amp; 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 &amp; "filename.xlsm"
            ActiveWorkbook.SaveAs _
                Filename:=filePath &amp; 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