VBA macro which filters and splits dataset into new workbooks

Question

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

Answer 1

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

Answer 2

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

Are the row heights actually different, or is this the only way you know how to set the row height for a range? Whenever possible, you should avoid looping when you could work with a Range object. In this case, Rows is a Range type, so you could just set them all at once.

ws.Rows.RowHeight = someHeight