Consolidation Macro runs too slow

[mcconnella]

I have built a macro to consolidate three unsimilar worksheets into one worksheet. Bascially the macros takes some information from an individual worksheet and adds data from the other worksheets based on the match of an item number (deal number in this case). I've tested a few times and seems to work okay with smaller data samples but when I use it on the actual data the macros just keeps running and never finishes. I left it going overnight last night to see if it would finish but it didn't.

I'm a beginner at this so I am just looking for some tips on how to make the code run faster. There's probably better ways to do what I've done and am just looking to improve!

Any suggestions would be greatly appreciated.

Here's the code:

Sub ConsolidateAllInfoNov3()
 
'Specify the start row for the New Workbook
Dim d
d = 2 'start at row 2
 
'Maximum Amount of rows to search through in each sheet, including the New Workbook
Dim MaxRows
MaxRows = 4000
 
'Specify the name of the new workbook
Application.ScreenUpdating = False
 
'Create new workbook
Workbooks.Add
ActiveWorkbook.saveas Filename:="P:\Admin\DTS\Consolidate Historial DTS\HistoricalData.xls", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
 
'Write column headers in new workbook
Range("a1").Value = "Data Source"
Range("b1").Value = "Department"
Range("c1").Value = "Associate"
Range("d1").Value = "Complete Deal#"
Range("e1").Value = "Deal#"
Range("f1").Value = "Deal Type"
Range("g1").Value = "Property Type"
Range("h1").Value = "Deal Status"
Range("i1").Value = "Deal Date"
Range("j1").Value = "Property Address"
Range("k1").Value = "Vendor/Landlord"
Range("l1").Value = "V/L Client"
Range("m1").Value = "Purchaser/Tenant"
Range("n1").Value = "P/T Client"
Range("o1").Value = "Associate Gross"
Range("p1").Value = "Associate Bonus"
Range("q1").Value = "Office Gross"
Range("r1").Value = "Area (SF)"
Range("s1").Value = "Land Size"
Range("t1").Value = "Transaction Value"
 
'Copy Data from Received workbook
Workbooks.Open Filename:="P:\Admin\DTS\Consolidate Historial DTS\received.xls"
Windows("HistoricalData.xls").Activate
 
For i = 6 To MaxRows 'start at row 6
If Not IsEmpty(Workbooks("received.xls").Sheets("Sheet1").Range("A" & i)) Then
Range("A" & d).Value = "Received" 'Data Source
Range("B" & d).Value = "212" 'Department
Range("C" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("A" & i) 'Associate
Range("D" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("B" & i) 'Complete Deal#
'Skip Deal#
'Skip Deal Type
'Skip Property Type
Range("H" & d).Value = "Recieved" 'Deal Status
Range("I" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("E" & i) 'Deal Date
'Skip Property Address, not on received report
Range("K" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("C" & i) 'Vendor/Landlord
'Skip V/L Client, not on received report
Range("M" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("D" & i) 'Purchaser/Tenant
'Skip P/T Client, not on received report
Range("O" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("H" & i) 'Associate Gross
Range("P" & d).Value = Workbooks("received.xls").Sheets("Sheet1").Range("J" & i) 'Associate Bonus
'Skip Office Gross, not on received report
'Skip Area, not on received report
'Skip Land Size, not on received report
'Skip Transaction Value, not on received report
d = d + 1
End If
Next i
 
'Copy Data from Pipeline workbook
Workbooks.Open Filename:="P:\Admin\DTS\Consolidate Historial DTS\pipeline.xls"
Workbooks("HistoricalData.xls").Activate
 
For i = 8 To MaxRows
If Not IsEmpty(Workbooks("pipeline.xls").Sheets("Sheet1").Range("A" & i)) Then
Range("A" & d).Value = "Pipeline" 'Data Source
Range("B" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("G" & i) 'Department
Range("C" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("A" & i) 'Associate
Range("D" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("E" & i) 'Complete Deal#
'Skip Deal#
'Skip Deal Type
'Skip Property Type
Range("H" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("D" & i) 'Deal Status
Range("I" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("C" & i) 'Deal Date
Range("J" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("H" & i) 'Property Address
Range("K" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("I" & i) 'Vendor/Landlord
'Skip V/L Client, not on pipeline report
Range("M" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("J" & i) 'Purchaser/Tenant
'Skip P/T Client, not on pipeline report
Range("O" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("M" & i) 'Associate Gross
'Skip Associate Bonus, not on pipeline report
Range("Q" & d).Value = Workbooks("pipeline.xls").Sheets("Sheet1").Range("L" & i) 'Office Gross
'Skip Area, not on received report
'Skip Land Size, not on received report
'Skip Transaction Value, not on received report
d = d + 1
End If
Next i
 
'Split complete deal# into Deal#, Deal Type and Property Type in Historial Data workbook
Workbooks("HistoricalData.xls").Activate
 
For i = 2 To MaxRows
 
If Not IsEmpty(Workbooks("HistoricalData.xls").Sheets("Sheet1").Range("D" & i)) Then
 
For h = 2 To MaxRows
 
Range("E" & h).Formula = "=IF(LEN(D" & h & ")=8,LEFT(D" & h & ",4),IF(LEN(D" & h & ")=9,LEFT(D" & h & ",5),IF(LEN(D" & h & ")=10,LEFT(D" & h & ",6),IF(LEN(D" & h & ")=12,LEFT(D" & h & ",5),LEFT(D" & h & ",6)))))" 'Insert formula into Deal #
'Copy of Formula =IF(LEN(E" & h & ")=8,LEFT(E" & h & ",4),IF(LEN(E" & h & ")=9,LEFT(E" & h & ",5),IF(LEN(E" & h & ")=10,LEFT(E" & h & ",6),IF(LEN(E" & h & ")=12,LEFT(E" & h & ",5),LEFT(E" & h & ",6)))))
Range("F" & h).Formula = "=IF(LEN(D" & h & ")=8,MID(D" & h & ",5,1),IF(LEN(D" & h & ")=9,MID(D" & h & ",6,1),IF(LEN(D" & h & ")=10,MID(D" & h & ",7,1),IF(LEN(D" & h & ")=12,MID(D" & h & ",6,1),MID(D" & h & ",7,1)))))" 'Insert formula into Deal Type
'Copy of Formula from Deal Type field =IF(LEN(E" & h & ")=8,MID(E" & h & ",5,1),IF(LEN(E" & h & ")=9,MID(E" & h & ",6,1),IF(LEN(E" & h & ")=10,MID(E" & h & ",7,1),IF(LEN(E" & h & ")=12,MID(E" & h & ",6,1),MID(E" & h & ",7,1)))))
Range("G" & h).Formula = "=IF(LEN(D" & h & ")<11,RIGHT(D" & h & ",3),IF(LEN(D" & h & ")=12,MID(D" & h & ",7,3),MID(D" & h & ",8,3)))" 'Insert formula into Property Type
'=IF(LEN(D" & h & ")<11,RIGHT(D" & h & ",3),IF(LEN(D" & h & ")=12,MID(D" & h & ",7,3),MID(D" & h & ",8,3)))
Next h
End If
Next i
 
'Copy Data from Transaction Report workbook
Workbooks.Open Filename:="P:\Admin\DTS\Consolidate Historial DTS\transaction.xls"
Windows("HistoricalData.xls").Activate
'Match deal numbers in HistoricalData and for every match copy deal status(?),v/l client, p/t client, area, land size and transaction value
 
For i = 8 To MaxRows
If Not IsEmpty(Workbooks("transaction.xls").Sheets("Sheet1").Range("B" & i)) Then
DealId = Workbooks("transaction.xls").Sheets("Sheet1").Range("A" & i).Value 'look at Deal# in Transaction Report
For h = 2 To MaxRows
If Trim(Workbooks("HistoricalData.xls").Sheets("Sheet1").Range("E" & h).Value) = Trim(DealId) Then
Range("A" & h).Value = "Transaction" 'Change data source to Transaction
Range("J" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("E" & i) 'Copy Property Address
Range("H" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("B" & i) 'Copy Deal Status
Range("L" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("G" & i) 'Copy V/L client
Range("N" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("J" & i) 'Copy P/T client
Range("R" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("M" & i) 'Copy Area
Range("S" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("N" & i) 'Land Size
Range("T" & h).Value = Workbooks("transaction.xls").Sheets("Sheet1").Range("O" & i) 'Transaction Value
 
End If
Next h
End If
Next i
 
'Close pipeline workbook without changes
Workbooks("pipeline.xls").Activate
ActiveWorkbook.Close savechanges:=False
 
'Close transaction workbook without changes
Workbooks("transaction.xls").Activate
ActiveWorkbook.Close savechanges:=False
 
'Close received workbook without changes
Workbooks("received.xls").Activate
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
 
End Sub

 

[Ruddles]

First of all, please endeavour to post any code between code tags - the # symbol in the editor toolbar: this will use a fixed width font and preserve the code indenting, both of which make it easier to look at code and will tend to attract more responses. Look back up at the code you posted and see if it isn't less readable than your VBE screen.

Regarding the content of your code, there's nothing glaringly obvious which might be causing your program to loop. I would always start a module off with Option Explicit to safeguard against mistryping variable names and I would have declared d and MaxRows as Long (prehaps), but that's not causing a problem.

I wouldn't Activate each workbook if I'm going to reference it by name - that might be slowing things down a little.

I suspect those nested loops: for each value of i from 2 to 4000 you're looping h round from 2 to 4000, so that's 16 million loops, inside each of which you're changing three formulae, each of which will trigger the workbook to be recalculated, so it's being recalculated 48 million times.

You need to pin down exactly where it's taking its time. Do this: immediately before the first FOR i= loop, enter the following instruction:-

Debug.Print "Stage 1: " & now()

and place a similar instruction before each of the other FOR i= loops - but not before that FOR h= loop! - then finally one after just before you close those three workbooks at the end, so five in all. Change the 'stage number' in each one so that you'll be able to identify the origin of each message.

Now open the Immediate Window (Ctrl-G) and keep it open and visible whilst you run your macro again. I suspect the first three messages will come up very quickly and the fourth one - the one after those nested loops - won't appear.

Those formulae don't appear to need to be recalculated immediately so let's turn off recalculation whilst that big loop is running.

Insert this instruction just after the comments "Split complete deal# into Deal#, Deal Type..." and "Match deal numbers in HistoricalData... ":-

[FONT=Courier New][COLOR=#003366]Application.Calculation = xlCalculationManual[/COLOR][/FONT]

and insert this before the comments "Copy Data from Transaction Report workbook" and "Close pipeline workbook without changes":-

[FONT=Courier New][COLOR=#003366]Application.Calculation = xlCalculationAutomatic[/COLOR][/FONT]

and try running your macro again - with the Immediate window visible.

Any better?

 

[mcconnella]

Thanks Ruddles...tried all that and you were right the fourth Stage message did not appear and the code seems to be getting stuck around this point:

'Split complete deal# into Deal#, Deal Type and Property Type in Historial Data workbook
Application.Calculation = xlCalculationManual
Workbooks("HistoricalData.xls").Activate
Debug.Print "Stage 1: " & Now()
For i = 2 To MaxRows
    
    If Not IsEmpty(Workbooks("HistoricalData.xls").Sheets("Sheet1").Range("D" & i)) Then
 
            For h = 2 To MaxRows
        
                Range("E" & h).Formula = "=IF(LEN(D" & h & ")=8,LEFT(D" & h & ",4),IF(LEN(D" & h & ")=9,LEFT(D" & h & ",5),IF(LEN(D" & h & ")=10,LEFT(D" & h & ",6),IF(LEN(D" & h & ")=12,LEFT(D" & h & ",5),LEFT(D" & h & ",6)))))" 'Insert formula into Deal #
                'Copy of Formula =IF(LEN(E" & h & ")=8,LEFT(E" & h & ",4),IF(LEN(E" & h & ")=9,LEFT(E" & h & ",5),IF(LEN(E" & h & ")=10,LEFT(E" & h & ",6),IF(LEN(E" & h & ")=12,LEFT(E" & h & ",5),LEFT(E" & h & ",6)))))
                Range("F" & h).Formula = "=IF(LEN(D" & h & ")=8,MID(D" & h & ",5,1),IF(LEN(D" & h & ")=9,MID(D" & h & ",6,1),IF(LEN(D" & h & ")=10,MID(D" & h & ",7,1),IF(LEN(D" & h & ")=12,MID(D" & h & ",6,1),MID(D" & h & ",7,1)))))" 'Insert formula into Deal Type
                'Copy of Formula from Deal Type field =IF(LEN(E" & h & ")=8,MID(E" & h & ",5,1),IF(LEN(E" & h & ")=9,MID(E" & h & ",6,1),IF(LEN(E" & h & ")=10,MID(E" & h & ",7,1),IF(LEN(E" & h & ")=12,MID(E" & h & ",6,1),MID(E" & h & ",7,1)))))
                Range("G" & h).Formula = "=IF(LEN(D" & h & ")<11,RIGHT(D" & h & ",3),IF(LEN(D" & h & ")=12,MID(D" & h & ",7,3),MID(D" & h & ",8,3)))" 'Insert formula into Property Type
                '=IF(LEN(D" & h & ")<11,RIGHT(D" & h & ",3),IF(LEN(D" & h & ")=12,MID(D" & h & ",7,3),MID(D" & h & ",8,3)))
            Next h
    End If
Next i

It still didn't complete running after I put in the application.calculation stuff you suggested.

In your opinion, does it make more sense for me to determine the number of non blank rows in each workbook at the beginning, set a variable for each and then use those variable instead of the code looping 4000 times?

 

[Ruddles]

Are there really 4000 rows of data? If not, you should only be looping as long as there's data there.

I'm not entirely clear what those nested loops are doing. Are you intentionally doing this: you loop through the sheet from row 2 to row 4000. For each cell in column D, if it has something in it, you're putting a formula in every row from 2 to 4000 of cols E, F & G.

In other words, you look at D2: if it has something in it, you put a formula in rows 2-4000 of cols E, F & G. Then you look at D3: if it has something in it, you put a formula in rows 2-4000 of cols E, F & G. Then you look at D4 - D5 - D6 - etc, and every time you're putting a formula in rows 2-4000 of cols E, F & G.

Is that correct? You have a 2-to-4000 loop inside which is another 2-to-4000 loop, so the inner loop is executed 16 million times.