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

Application.ScreenUpdating = False

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

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.SaveAs _
Filename:="C:\...\" & rng & "filename.xlsm ", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled

ActiveWorkbook.Close 'SaveChanges:=True

Next rng
Sheets("temp").Delete

End With

Application.ScreenUpdating = True

End Sub

• Am I mistaken or are you just taking each unique value from a column and placing it on a new sheet with every other item that shares that value? – Raystafarian Aug 20 '15 at 16:09

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.ScreenUpdating = False

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

Set newBookNames = New Collection

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

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

filePath = "C:\...\"
newFileName = rng & "filename.xlsm"
ActiveWorkbook.SaveAs _
Filename:=filePath & newFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled

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.ScreenUpdating = True

End Sub

• Thank you for a comprehensive response. Both you and previous poster's comments are on point and have helped me optimize the macro, plus nudged me to learn about the Calculation functionality. – A.S Aug 20 '15 at 23:41
• Good call on the calculation Chip. – RubberDuck Aug 20 '15 at 23:51
   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

• Relaxing the row calculation routine definitely helped, so your answer is valid and saved me much time waiting today. Thank you for the prompt response! I will have to give a correct mark to @ChipsLetten for a more complete response with additional suggestions. But both were indeed on point and the code runs significantly faster once I hard-coded some row formats rather than make it iterate. – A.S Aug 20 '15 at 23:40