Help Reduce Macro Time For 20,000 rows Takes 1 hr and 23min!

M

matt9man

New Member
Joined
Jan 4, 2011
Messages
22
Background:
So I have 20 procedure macro that does the following operations:
Clears cells from sheets, open inputs files, copys input data, creates keys by using logical keys for expected and actual, compares expected and actual results by doing vlookup off of expected key - highlights wrong cells, highlights red duplicates of actual and expected in there sheets, and then lastly finds extra actuals that are not in expected sheet and copys that key in underneath all comparisons.

Problem: Orginally it took 2.5 hours for the Macro to compare 20,000 rows from two input files.

Now it takes 1h20min by adding manual calculation syntax and cancel screen updating.

What else can I do to reduce the time to complete 20,000 rows from 1h20min to 20 - 30 min?

Thanks(Let me know if you need code theres like 30 pages) :laugh:
 
Sort by date Sort by votes
I found same problem in that macro too.

change
Sub PopulateAct(intCompRow)
to
Sub PopulateAct(intCompRow As Long)
 
Upvote 0
'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)

Call CompareData(intCompRow As Long, intCol As Long)
 intCol = intCol + 1
Click to expand...

I think that jon's suggestion was to change the procedure's signature. You never put the data type in the call.
 
Upvote 0
Yea I realized that stupid mistake. I changed it and now it works. Thanks jonmo!

Problem though its comparing 5000 rows in about 2min 30 seconds. My final set can be as much as 20,000 so the there will total of 40,000 rows in the "compare Results" tab one for each expected and actual result.

Any ideas on using Bill's
<TABLE border=0 cellSpacing=0 cellPadding=6 width="100%"><TBODY><TR><TD style="BORDER-BOTTOM: 1px inset; BORDER-LEFT: 1px inset; BORDER-TOP: 1px inset; BORDER-RIGHT: 1px inset" class=alt2>5. Instead of looping through all 20,000 rows develop a formula that can be copy into all 20,000 rows with one statement. Then turn calculations on. After calculation then change the formulas to values.</TD></TR></TBODY></TABLE>
Click to expand...
On the following code (Code with Jonmo's corrections)
Code: 
Sub PopulateExp()
'Takes expected data populates it every other row until all expected are shown in the Compare Result Sheet

Dim intExpRow As Long
Dim intCompRow As Long
Dim intCol As Long
Application.ScreenUpdating = False
intExpRow = 3
intCompRow = 3
intCol = 1
Sheet3.Select
intRowCnt = Sheet4.Cells(1, 2)
Call ClearAllComp
While Sheet2.Cells(intExpRow, intCol) <> ""
   Sheet3.Cells(intCompRow, intCol) = "Expected"
   Sheet3.Cells(intCompRow, intCol + 1) = Sheet2.Cells(intExpRow, intCol + 1)
   Sheet3.Cells(intCompRow, intCol + 2) = Sheet2.Cells(intExpRow, intCol + 2)
   Sheet3.Cells(intCompRow, intCol + 3) = Sheet2.Cells(intExpRow, intCol)
   
   While (intCol <= intRowCnt)
   Sheet3.Cells(intCompRow, intCol + 4) = Sheet2.Cells(intExpRow, intCol + 3).Value
   intCol = intCol + 1
   Wend
   
   Sheet3.Rows(intCompRow).Select
   
    With Selection.Interior
        .ColorIndex = 34
        .Pattern = xlSolid
    End With
   
   Call PopulateAct(intCompRow)
   
   intCompRow = intCompRow + 2
   intExpRow = intExpRow + 1
   
   
intCol = 1
Wend
End Sub
Sub PopulateAct(intCompRow As Long)
'Takes actual data populates below the expected result by using the key and the vlookup value in expected range
Dim intExpRow As Long
Dim intCol As Long
intCol = 1
intRowCnt = Sheet4.Cells(1, 2)
Sheet3.Select
   Sheet3.Cells(intCompRow + 1, intCol) = "Actual"
   Sheet3.Cells(intCompRow + 1, intCol + 1) = Sheet3.Cells(intCompRow, intCol + 1)
   Sheet3.Cells(intCompRow + 1, intCol + 2) = Sheet3.Cells(intCompRow, intCol + 2)
   
   While (intCol <= intRowCnt + 1)
   Sheet3.Cells(intCompRow + 1, intCol + 3) = "=VLOOKUP(D" & intCompRow & ",Actual!A1:BP90000," & (intCol) & ",FALSE)"
   'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)
    
   Call CompareData(intCompRow)
   intCol = intCol + 1
   Wend
End Sub

Sub CompareData(intCompRow As Long)
'Take the actual against expected and shows the differences by color
    If IsError(Sheet3.Cells(intCompRow + 1, intCol + 3).Value) Then
      Sheet3.Cells(intCompRow + 1, intCol + 3) = "Actual Result Not Found"
      Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
      Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
      Sheet3.Rows(intCompRow + 1).Interior.ColorIndex = 40
      intCol = intRowCnt + 1 'To exit the while loop
    Else
        If Sheet3.Cells(intCompRow + 1, intCol + 3).Value = Sheet3.Cells(intCompRow, intCol + 3).Value Then
        Else
            Sheet3.Cells(intCompRow + 1, intCol + 3).Interior.ColorIndex = 40
            Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
            Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
        End If
    
    End If
   
End Sub
Thanks again.
 
Upvote 0
I would put the code back in to turn off Calculation
And also turn off Events

At the begining of the main procedure populateexp

Code: 
Dim xlCalc As Variant
With Applicaiton
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .Screenupdating = False
    .EnableEvents = False
End With

Then at the end of that procedure populateexp
Code: 
With Applicaiton
    .Calculation = xlCalc
    .Screenupdating = True
    .EnableEvents = True
End With
 
Last edited:
Upvote 0
Yea I forgot to mention I put that code in the first procedure before it calls all the others and at end of the macro.

But I have a new problem now...
When there is over 10,0000 rows in my "compare results" tab and i try to clear it with below code there is a "Clear Method of Range Class Failed" error.

Code: 
Sub ClearAllComp()
'Selects starting at A3 to all cells that have data in it
'Then clears the data
    Range("A3", Selection.SpecialCells(xlLastCell)).Clear
End Sub

I tried putting in what bill said
2.Use as few “select” statements as possible. Selection takes time.
Instead of

Range("A1", Selection.SpecialCells(xlLastCell)).Select
Selection.Copy
use
Range("A1", Range("A65356").End(xlUp)).Copy ‘(xlLastCell is unreliable)
Click to expand...
but doesn't work because my selection is not in same column it is sometimes (A3,ZZ100000)

thanks
 
Last edited:
Upvote 0
Used your “ConstructKey procedure and came up with the following
Not sure if I have your formula correct, but you can correct as necessary. Looks like you build the keys from variable cells based on data in sheet4 column D, rows 2 through 20. You need to determan the correct range .
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
This procedure builds the formulas in column A of sheet5 and then converts the calculated result to values. 20,000 rows took 3 seconds
<o:p></o:p>
Code: 
Sub ConstrucKeyAct_New()<o:p></o:p>
    Dim a(20)<o:p></o:p>
    Dim i As Long<o:p></o:p>
 <o:p></o:p>
    'get the reference column numbers<o:p></o:p>
    Sheet4.Select<o:p></o:p>
    For i = 1 To 20<o:p></o:p>
        a(i) = Sheet4.Cells(i, 4) + 3<o:p></o:p>
    Next i<o:p></o:p>
 <o:p></o:p>
    'construct formula and paste to range<o:p></o:p>
    Sheet5.Select<o:p></o:p>
    Sheet5.Range("A1:A20000").FormulaR1C1 = "=rc[" & a(2) & "]" _<o:p></o:p>
    & " & rc[" & a(3) & "]" & " & rc[" & a(4) & "]" _<o:p></o:p>
    & " & rc[" & a(5) & "]" & " & rc[" & a(6) & "]" _<o:p></o:p>
    & " & rc[" & a(7) & "]" & " & rc[" & a(8) & "]" _<o:p></o:p>
    & " & rc[" & a(9) & "]" & " & rc[" & a(10) & "]" _<o:p></o:p>
    & " & rc[" & a(11) & "]" & " & rc[" & a(12) & "]" _<o:p></o:p>
    & " & rc[" & a(13) & "]" & " & rc[" & a(14) & "]" _<o:p></o:p>
    & " & rc[" & a(15) & "]" & " & rc[" & a(16) & "]" _<o:p></o:p>
    & " & rc[" & a(17) & "]" & " & rc[" & a(18) & "]" _<o:p></o:p>
    & " & rc[" & a(19) & "]" & " & rc[" & a(20) & "]"<o:p></o:p>
    <o:p></o:p>
    'convert column to values<o:p></o:p>
    Columns("A:A").Copy<o:p></o:p>
    Columns("A:A").PasteSpecial Paste:=xlValues<o:p></o:p>
    Application.CutCopyMode = False<o:p></o:p>
 <o:p></o:p>
End Sub
 
Upvote 0
You can save a lot of headachs by using Option Explicit and Dim all your variables outside of procedure statements, but usually within teh procedure at the top.
 
Upvote 0
Below in red gave mismatch?
Code: 
Sub ConstrucKeyAct_New()<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
    Dim a(20)<o:p></o:p>
    Dim i As Long<o:p></o:p>
 <o:p></o:p>
    'get the reference column numbers<o:p></o:p>
    Sheet4.Select<o:p></o:p>
    For i = 1 To 20<o:p></o:p>
        [COLOR=red]a(i) = Sheet4.Cells(i, 4) + 3<o:p></o:p>[/COLOR]
    Next i<o:p></o:p>
 <o:p></o:p>
    'construct formula and paste to range<o:p></o:p>
    Sheet5.Select<o:p></o:p>
    Sheet5.Range("A1:A20000").FormulaR1C1 = "=rc[" & a(2) & "]" _<o:p></o:p>
    & " & rc[" & a(3) & "]" & " & rc[" & a(4) & "]" _<o:p></o:p>
    & " & rc[" & a(5) & "]" & " & rc[" & a(6) & "]" _<o:p></o:p>
    & " & rc[" & a(7) & "]" & " & rc[" & a(8) & "]" _<o:p></o:p>
    & " & rc[" & a(9) & "]" & " & rc[" & a(10) & "]" _<o:p></o:p>
    & " & rc[" & a(11) & "]" & " & rc[" & a(12) & "]" _<o:p></o:p>
    & " & rc[" & a(13) & "]" & " & rc[" & a(14) & "]" _<o:p></o:p>
    & " & rc[" & a(15) & "]" & " & rc[" & a(16) & "]" _<o:p></o:p>
    & " & rc[" & a(17) & "]" & " & rc[" & a(18) & "]" _<o:p></o:p>
    & " & rc[" & a(19) & "]" & " & rc[" & a(20) & "]"<o:p></o:p>
    <o:p></o:p>
    'convert column to values<o:p></o:p>
    Columns("A:A").Copy<o:p></o:p>
    Columns("A:A").PasteSpecial Paste:=xlValues<o:p></o:p>
    Application.CutCopyMode = False<o:p></o:p>
 <o:p></o:p>
End Sub
Click to expand...
The majority of this orginal code was pretty quick its this part that took the longest:
Code: 
Sub PopulateExp()
'Takes expected data populates it every other row until all expected are shown in the Compare Result Sheet
 
Dim intExpRow As Long
Dim intCompRow As Long
Dim intCol As Long
Application.ScreenUpdating = False
intExpRow = 3
intCompRow = 3
intCol = 1
Sheet3.Select
intRowCnt = Sheet4.Cells(1, 2)
Call ClearAllComp
While Sheet2.Cells(intExpRow, intCol) <> ""
   Sheet3.Cells(intCompRow, intCol) = "Expected"
   Sheet3.Cells(intCompRow, intCol + 1) = Sheet2.Cells(intExpRow, intCol + 1)
   Sheet3.Cells(intCompRow, intCol + 2) = Sheet2.Cells(intExpRow, intCol + 2)
   Sheet3.Cells(intCompRow, intCol + 3) = Sheet2.Cells(intExpRow, intCol)
 
   While (intCol <= intRowCnt)
   Sheet3.Cells(intCompRow, intCol + 4) = Sheet2.Cells(intExpRow, intCol + 3).Value
   intCol = intCol + 1
   Wend
 
   Sheet3.Rows(intCompRow).Select
 
    With Selection.Interior
        .ColorIndex = 34
        .Pattern = xlSolid
    End With
 
   Call PopulateAct(intCompRow)
 
   intCompRow = intCompRow + 2
   intExpRow = intExpRow + 1
 
 
intCol = 1
Wend
End Sub
Sub PopulateAct(intCompRow As Long)
'Takes actual data populates below the expected result by using the key and the vlookup value in expected range
Dim intExpRow As Long
Dim intCol As Long
intCol = 1
intRowCnt = Sheet4.Cells(1, 2)
Sheet3.Select
   Sheet3.Cells(intCompRow + 1, intCol) = "Actual"
   Sheet3.Cells(intCompRow + 1, intCol + 1) = Sheet3.Cells(intCompRow, intCol + 1)
   Sheet3.Cells(intCompRow + 1, intCol + 2) = Sheet3.Cells(intCompRow, intCol + 2)
 
   While (intCol <= intRowCnt + 1)
   Sheet3.Cells(intCompRow + 1, intCol + 3) = "=VLOOKUP(D" & intCompRow & ",Actual!A1:BP90000," & (intCol) & ",FALSE)"
   'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)
 
   Call CompareData(intCompRow)
   intCol = intCol + 1
   Wend
End Sub
 
Sub CompareData(intCompRow As Long)
'Take the actual against expected and shows the differences by color
    If IsError(Sheet3.Cells(intCompRow + 1, intCol + 3).Value) Then
      Sheet3.Cells(intCompRow + 1, intCol + 3) = "Actual Result Not Found"
      Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
      Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
      Sheet3.Rows(intCompRow + 1).Interior.ColorIndex = 40
      intCol = intRowCnt + 1 'To exit the while loop
    Else
        If Sheet3.Cells(intCompRow + 1, intCol + 3).Value = Sheet3.Cells(intCompRow, intCol + 3).Value Then
        Else
            Sheet3.Cells(intCompRow + 1, intCol + 3).Interior.ColorIndex = 40
            Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
            Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
        End If
 
    End If
 
End Sub

You recommended to
5. Instead of looping through all 20,000 rows develop a formula that can be copy into all 20,000 rows with one statement. Then turn calculations on. After calculation then change the formulas to values.
Click to expand...

How would I do that?
 
Last edited:
Upvote 0
In your ConstrucKeyAct procedure you billed the key by concatenating a number of cells using the “Cells” statement.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
Code: 
[COLOR=black]strKey = Sheet5.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _<o:p></o:p>[/COLOR]
 <o:p></o:p>
The column number is made up of intCol which is set to 3 plus a variable in sheet 4, column 4. The row number is hard coded.<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
I set up an array for the variables in sheet 4 to reduce the verbiage in the statement that constructs the key. This loop expects an integer in sheet 4, column 4., the first 20 rows. (but you may have a header in row 1)<o:p></o:p>
<o:p></o:p>
Code: 
[COLOR=black]    'get the reference column numbers<o:p></o:p>[/COLOR]
[COLOR=black]    Sheet4.Select<o:p></o:p>[/COLOR]
[COLOR=black]    For i = 1 To 20<o:p></o:p>[/COLOR]
[COLOR=black]        a(i) = Sheet4.Cells(i, 4) + 3<o:p></o:p>[/COLOR]
[COLOR=black]    Next i[/COLOR]
 <o:p></o:p>
Is this correct?<o:p></o:p>
<o:p></o:p>
You may have a header in row one so change the code to <o:p></o:p>
Code: 
[COLOR=black]    'get the reference column numbers<o:p></o:p>[/COLOR]
[COLOR=black]    Sheet4.Select<o:p></o:p>[/COLOR]
[COLOR=black]    For i = 2 To 20<o:p></o:p>[/COLOR]
[COLOR=black]        a(i) = Sheet4.Cells(i, 4) + 3<o:p></o:p>[/COLOR]
[COLOR=black][FONT=Times New Roman]    Next i[/FONT][/COLOR]
 
Upvote 0
matt9man

Have you considered the overall flow of this code?

You seem to be trying to do everything at the same time.

At first you seem to be simply copying data from one worksheet to another, manipulating the data a bit when you do so.

eg change columns/rows etc

But then it appears you are doing that one row at a time and also doing a whole lot of calculations/comparisons while you are doing it.

I assume that is why you call CompareData within the loop.

Why not do the data 'transfer' then do the calculation/comparison?

Also, are you sure VLOOKUP is the appropriate formula to be using to check the data?

PS Whoever suggested inserting all the formulas in one go has a very good point.:)

PS If you want to clear the results try this, which doesn't need any selection.
Code: 
Sheet3.Range("A3", Sheet3.Range("A" & Rows.Count).End(xlUp)).EntireRow.Clear
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Reduce size of (or speed up) excel spreadsheet
Replies
5
Views
350
helpcharity
H
S
  • Question Question
VBA code for adding new group of columns with 3 condictions from 2 dictionary and 1 array Then fill in data from value from original columns
Replies
1
Views
179
sijpie
sijpie
ChrisMac1
  • Question Question
VBA - Compare specific data in one column on one sheet, with the same column on 4 other sheets, copy specific cells if match found.
Replies
1
Views
510
ChrisMac1
ChrisMac1
M
  • Question Question
Conditional Formatting/Moving Rows Based on Matching and Opposite Data
Replies
1
Views
393
Madam_Xavier
M
C
  • Question Question
Combining rows 3 through 7 into row 2, one row takes a painfully long time with this code. Why?
Replies
2
Views
283
jolivanes
jolivanes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top