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
Thanks for the blog link I'll take a look at it.

Kap - 1.I used 'find' first but the problem is that my keys have \. so it doesn't work.
2.Current code does import two workbooks to one.

Thanks tho any other ideas?

In the mean time here is my code. Sorry for the length.
-------------
Dim intRowCnt As Long
Sub CompareResult()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'The macro that calls all the procedures
'ctrl t is the shortcut to run this macro
intRowCnt = Sheet4.Cells(1, 2)
'Clears expected,actual, and compare sheets in prepartion for data migration
Sheet2.Select
Call ClearAllComp
Sheet5.Select
Call ClearAllComp
Sheet3.Select
Call ClearAllComp

Call OpenExpectedData
'First using Logic Key tab finds data and copies and pastes into Actual and Expected tabs
Call OpenActualData
'Second construct key (required for comparison) for actual result

Call ConstrucKeyAct
Call ConstrucKeyExp
Application.ScreenUpdating = False
Call PopulateExp
Call DuplicatesActual
Call DuplicatesExpected
Call ExtraActuals
Application.ScreenUpdating = True
Worksheets("Compare Result").Select
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub


Sub ConstrucKeyAct()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Dim intRow As Long
Dim intCol As Long
Dim strKey As String
intRow = 3
intCol = 1
Sheet5.Select
Call ClearCellA
'Constructs key off of what is specified in Sheet 4 or Logical Key tab where which fields you want in the key
'Are specified by numbers and listed above each column in Expected and Actual sheets in row 1
While (Sheet5.Cells(intRow, intCol + 1) <> "")
strKey = Sheet5.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(3, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(4, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(5, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(6, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(7, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(8, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(9, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(10, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(11, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(12, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(13, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(14, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(15, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(16, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(17, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(18, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(19, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(20, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(21, 4))




Sheet5.Cells(intRow, intCol) = strKey
intRow = intRow + 1
Wend
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub


Sub ConstrucKeyExp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Dim intRow As Long
Dim intCol As Long
intRow = 3
intCol = 3
Sheet2.Select
Call ClearCellA
'Constructs key off of what is specified in Sheet 4 or Logical Key tab where which fields you want in the key
'Are specified by numbers and listed above each column in Expected and Actual sheets in row 1
While (Sheet2.Cells(intRow, intCol + 1) <> "")
Sheet2.Cells(intRow, intCol - 2) = Sheet2.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(3, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(4, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(5, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(6, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(7, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(8, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(9, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(10, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(11, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(12, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(13, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(14, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(15, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(16, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(17, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(18, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(19, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(20, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(21, 4))
intRow = intRow + 1
Wend
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub


Sub ClearCellA()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'
'Clearing cell A through 10,000 because couldn't find last data cell to clear in just column A
Range("A3:A100000").Select

Selection.ClearContents
Range("A2").Select

Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub


Sub PopulateExp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'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
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
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub


Sub PopulateAct(intCompRow)
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'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
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:BP150000," & (intCol) & ",FALSE)"
'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)

Call CompareData(intCompRow, intCol)
intCol = intCol + 1
Wend
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub

Sub CompareData(intCompRow, intCol)
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'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
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub

Sub ClearAllComp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Selects starting at A3 to all cells that have data in it
'Then clears the data
Range("A3", Selection.SpecialCells(xlLastCell)).Select
Selection.Clear
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub

Sub OpenActualData()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Selects starting at A3 to all cells that have data in it
'Then clears the data
' OpenActualData Macro
' Find the key with link to worksheet then copys data into cells current workbook.
currentworkbook = Worksheets("Logical Key").Range("B15")
'variable for when the spreadsheet name changes project to project
Sheets("Logical Key").Select
Range("B12").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Range("A1", Selection.SpecialCells(xlLastCell)).Select
'In the Actual input file opens and finds all data from range A2,to last populated cell

Selection.Copy
ActiveWorkbook.Close SaveChanges:=True
Windows(currentworkbook).Activate
Sheets("Actual").Select
Range("B2").Select
ActiveSheet.Paste

Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub

Sub OpenExpectedData()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
' OpenExpectedData Macro
' Find the key with link to worksheet then copys data into cells current workbook.
currentworkbook = Worksheets("Logical Key").Range("B15")
'variable for when the spreadsheet name changes project to project
Sheets("Logical Key").Select
Range("B13").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Range("A1", Selection.SpecialCells(xlLastCell)).Select
'In Expected input file opens and finds all data from range A2,to last populated cell

Selection.Copy
ActiveWorkbook.Close SaveChanges:=True
Windows(currentworkbook).Activate
Sheets("Expected").Select
Range("D2").Select
ActiveSheet.Paste
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub

Sub DuplicatesActual()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Application.Wait Now + TimeValue("0:00:01")
'Delay because the CompareData takes some time and the this procedure like to start before that loop is complete
' Conditional formats cells for Actual results by red for duplicates in the key
Sheets("Actual").Select
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub

Sub DuplicatesExpected()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Application.Wait Now + TimeValue("0:00:01")
'Delay because the CompareData takes some time and the this procedure like to start before that loop is complete
' Conditional formats cells for Expected results by red for duplicates in the key
Sheets("Expected").Select
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub

Sub ExtraActuals()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'This procedure is looking for the keys that are not in expected but are in Actual.
Application.Wait Now + TimeValue("0:00:02")
x = 5
'The variable to copy values 5 rows below the last data on that sheet
Dim Res As Variant, lookupval As Variant
Dim lookuprng As Range, c As Range
Dim LR As Long
'Below is the lookupval column of Actual Keys
LR = Sheets("Actual").Cells(Rows.Count, "A").End(xlUp).Row
Set lookuprng = Worksheets("Expected").Range("A3:A150000")
'Above is range of the lookup in the Expected tab
For Each c In Sheets("Actual").Range("A3:A" & LR)
lookupval = c.Value
Res = Application.Match(lookupval, lookuprng, 0)
'Now its looking for a match between Actual and Expected keys
'When there isn't a match it returns the lookupval aka actual extra key

If IsError(Res) Then
Sheets("Compare Result").Cells(Rows.Count, "D").End(xlUp).Offset(x).Value = c.Value


'Below is the label for extras

Sheets("Compare Result").Select
Range("A6").Select
Selection.End(xlDown).Select
ActiveCell.Offset(5, 0).Select
Selection = "Extra Actuals"
Selection.Interior.ColorIndex = 6
x = 1
'Now has cells that are being copied 1 row below last actual extra.

End If
Next c
Application.Calculation = xlCalc

Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
 
Last edited:
Upvote 0
copy the files to your local drive (rather than running over network). thanks

Kaps
 
Upvote 0
Consider replacing :-

Code: 
Sheet2.Cells(intRow, intCol - 2) = Sheet2.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(3, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(4, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(5, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(6, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(7, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(8, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(9, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(10, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(11, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(12, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(13, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(14, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(15, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(16, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(17, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(18, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(19, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(20, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(21, 4))

with a FOR NEXT LOOP e.g untested:-

Code: 
Dim i as long
dim temp_str as string
temp_str = ""
for i = 2 to 21
       temp_str = temp_str & Sheet2.Cells(intRow, intCol + Sheet4.Cells(i, 4))
next i
Sheet2.Cells(intRow, intCol - 2) = temp_str

thanks

Kaps
 
Upvote 0
Great idea. I tested it and it only creates the key in A3 and so A4 and down are blank. I couldn't figure out how to fix it any ideas?

Code: 
Sub ConstrucKeyExp()
Dim xlCalc As XlCalculation
    xlCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    On Error GoTo CalcBack
Dim intRow As Long
Dim intCol As Long
intRow = 3
intCol = 3
Sheet2.Select
Call ClearCellA
'Constructs key off of what is specified in Sheet 4 or Logical Key tab where which fields you want in the key
'Are specified  by numbers and listed above each column in Expected and Actual sheets in row 1
Dim i As Long
Dim temp_str As String
temp_str = ""
For i = 2 To 21
       temp_str = temp_str & Sheet2.Cells(intRow, intCol + Sheet4.Cells(i, 4))
Next i
Sheet2.Cells(intRow, intCol - 2) = temp_str
Application.Calculation = xlCalc
 
    Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
2.I also have noticed in the below three procedures it takes the most time because its populating actual and expected then comparing any recommendation on how to speed this up? Thanks a lot.

Code: 
Sub PopulateExp()
Dim xlCalc As XlCalculation
    xlCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    On Error GoTo CalcBack
'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
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
Application.Calculation = xlCalc
 
    Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
 
Sub PopulateAct(intCompRow)
Dim xlCalc As XlCalculation
    xlCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    On Error GoTo CalcBack
'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
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:BP150000," & (intCol) & ",FALSE)"
   'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)
 
   Call CompareData(intCompRow, intCol)
   intCol = intCol + 1
   Wend
Application.Calculation = xlCalc
 
    Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
 
Sub CompareData(intCompRow, intCol)
Dim xlCalc As XlCalculation
    xlCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    On Error GoTo CalcBack
'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
   Application.Calculation = xlCalc
 
    Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
 
Upvote 0
My apologies I didn't realize that these were from the same website... I was under the assumption that mr.excel.com and excelforum.com were different forums and I had to register to both.
 
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
344
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
173
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
507
ChrisMac1
ChrisMac1
M
  • Question Question
Conditional Formatting/Moving Rows Based on Matching and Opposite Data
Replies
1
Views
382
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
280
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