Slow Calculation of Sum Row

[Ajannear]

Good Morning,

I am a beginner in VBA and am trying to improve performance of my doc control register. The current code works fine, however when this is updated to have data return value on a different worksheet, or values summed onto a different worksheet it takes 5 to 8 mins to process all info. The example included is significantly reduced, we have about 2000 lines that need to be processed.

The goal of the code is to check all documents on our 'Cross-Referencing Docs' sheet that have other docs referenced within them and check these doc #'s against our 'Doc Register' list, and then colour code if 'Inactive' or do not exist (Bad ID). Currently, after completing this check, the code does a count on the total number of Inactive or Bad ID docs per row and returns the value at the end of the row, however we want the result to be on the 'Doc Register' sheet.

Below is the code we used the have the value's return on the Doc Register worksheet instead of the Cross-Referencing sheet - We have also attempted to use a Sum code and then calling that after completion of the count, also below.


Sub Check_For_Inactive_References()


'=====declare variables================================================================== ====
Dim Inactive_Reference_Count As Integer
Dim BadDocID_Count As Integer
Dim ColumnRange As Range
Dim StartRow As Integer
Dim EndRow As Integer
Dim StartColumn As String
Dim Inactive_Total_Column As String
Dim Bad_ID_Total_Column As String


'=====initialise variables================================================================== ===
StartRow = 2
EndRow = 2000
StartColumn = "I"
EndColumn = "Z"
Inactive_Total_Column = "G" 'IF WE USE THE SUM FUNCTION, THIS WILL BE "CY"
Bad_ID_Total_Column = "H" 'IF WE USE THE SUM FUNCTION, THIS WILL BE "CZ"


MsgBox ("Checking for totals against each Doc ID, please wait")


'=====scan through all rows in the sheet and then execute the "for each" function within this loop for each row===
Do Until StartRow > EndRow 'keep looping until the counter gets up to the last row


'=====Check the row the script is up to for number of inactive and bad ID documents===========
For Each ColumnRange In Sheet3.Range(StartColumn & StartRow & ":" & EndColumn & StartRow)

Select Case ColumnRange.Interior.ColorIndex 'check the color of the current cell
Case Is = 3 'if the current cell is RED
Inactive_Reference_Count = Inactive_Reference_Count + 1 'Increase inactive counter for the current row by 1
Case Is = 7 'if the current cell is MAGENTA
BadDocID_Count = BadDocID_Count + 1 'increase bad doc ID counter for the current row by 1
Case Else
'do nothing
End Select

Next ColumnRange

Sheet2.Range(Inactive_Total_Column & StartRow) = Inactive_Reference_Count 'write inactive count total against the row in sheet - IF WE USE THE SUM FUNCTIONS THIS WILL BE SHEET3
Sheet2.Range(Bad_ID_Total_Column & StartRow) = BadDocID_Count 'write bad doc id count total against the row in sheet - IF WE USE THE SUM FUNCTIONS THIS WILL BE SHEET3

Inactive_Reference_Count = 0 'once values are written to the sheet, reset them back to 0 ready for next row
BadDocID_Count = 0 'once values are written to the sheet, reset them back to 0 ready for next row
'========================================================================== =====================

StartRow = StartRow + 1 'increment to the next row and repeat the loop again


Loop


MsgBox ("Complete")


End Sub



SUM OF COUNT:


Sub COUNT_DODGY_DOCS()


On Error Resume Next
Dim Count_Inactive_Row As Long
Dim Dept_Clm As Long
Table1 = Sheet2.Range("B2:H2000")
Table2 = Sheet3.Range("D2:CZ2000")


Count_Inactive_Row = Sheet2.Range("G2").Row
Dept_Clm = Sheet2.Range("G2").Column
For Each cl In Table1
Sheet2.Cells(Count_Inactive_Row, Dept_Clm) = Application.WorksheetFunction.VLookup(cl, Table2, 100, False)
Count_Inactive_Row = Count_Inactive_Row + 1

Next cl




End Sub


Any help would be appreciated.

Thanks

[Paul_Hossler]

I only looked at COUNT_DODGY_DOCS

The first tow subs seems to run pretty quick, but this one was really slow since you were doing what seemed to be a lot of unnecessary processing (extra rows, all cells in a Table, etc.)

I used 2 arrays for speed, and I've found for me at least I make less mistakes if I use A1:something-something instead of B2:H2000 since cells counts/indices are relative to the over-arching Range (i.e. Cells(1,1) in B2:H2000 is B2)

I just want to avoid silly mistakes



Option Explicit


Sub COUNT_DODGY_DOCS()
Dim Table2 As Range, Table3 As Range
Dim Dept_Clm As Long
Dim rowLast2 As Long, rowLast3 As Long, rowInactive As Long, n As Long
Dim sDoc As String
Dim aryCol4 As Variant, aryCol104 As Variant


With Sheet2 ' Doc Register sheet
rowLast2 = .Cells(.Rows.Count, 2).End(xlUp).Row
Set Table2 = .Cells(1, 1).Resize(rowLast2, 7)
End With

With Sheet3 ' Cross Ref Docs sheet
rowLast3 = .Cells(.Rows.Count, 4).End(xlUp).Row
Set Table3 = .Cells(1, 1).Resize(rowLast3, 104)
aryCol4 = Application.WorksheetFunction.Transpose(Table3.Columns(4))
aryCol104 = Application.WorksheetFunction.Transpose(Table3.Columns(104))
End With


Dept_Clm = 7

For rowInactive = 2 To rowLast2
sDoc = Table2.Cells(rowInactive, 2).Value

n = 0
On Error Resume Next
n = Application.WorksheetFunction.Match(sDoc, aryCol4, 0)
On Error GoTo 0

If n = 0 Then
Table2.Cells(rowInactive, Dept_Clm) = ""
Else
Table2.Cells(rowInactive, Dept_Clm) = aryCol104(n)
End If
Next rowInactive


MsgBox "Complete"


End Sub

[Ajannear]

Hi Paul,
Thanks for responding. I did run your code and it has shaved some time off, however still sitting at 3 minutes (ish) to run all 3 codes together. I was really hoping to have this time reduced down to less than a minute but will take onboard your advice and keep playing with it to see if I can get something to stick.

[snb]

I looked at: Sub Check_For_Inactive_Documents()

Why don't you use 2 ( red & magenta) simple conditional formatting rules in range I2:Z2000 in sheet 'cross referencing docs' ?
You don't need any VBA for this;
You won't even notice the calculation time.

To count the inactive lines: use countif instead of VBA.

[snb]

To reduce execution time in VBA:

Only read data form a workbook once.
Only write results into a workbook once.

Avoid any other reading/writing opeerations in any worksheet.

Use Arrays to store data in.
Use Arrays to do the calculations.

Open any other files using GetObject.

Avoid the use of Excel formulae (worksheetfunctions).

Use Dictionaries if many comparisons are required.


NB. Application screenupdating=false & application.calculation=manual are only an indication that the interaction between the code and the workbook is too unnecessarily frequent.

[Ajannear]

Hi snb,

We originally had this set as a conditional format, however we couldn't work out a function to count each conditionally-coloured cell per row.

We have approx 80 columns and 2000 rows of data so nesting countif and vlookups for this many cells isn't something we want to consider at this stage.

Are you aware of any basic functions that could be used instead of vba to counter this?

[snb]

Why would you like to count the number of coloured cells per row ?

[snb]

Why would you like to count the number of coloured cells per row ?
You'd better use a comparable formula as used for the conditional formatting.

[snb]

Definitely the fastest way to count the 'inactives' and 'Bads':


Sub M_snb()
sp = Sheet2.ListObjects(1).DataBodyRange
sn = Sheet3.ListObjects(1).DataBodyRange

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sp)
.Item(sp(j, 2)) = sp(j, 17)
Next

For j = 1 To UBound(sn)
sn(j, UBound(sn, 2)) = 0
sn(j, UBound(sn, 2) - 1) = 0

For jj = 6 To 22
If .exists(sn(j, jj)) Then
If .Item(sn(j, jj)) = "Inactive" Then sn(j, UBound(sn, 2) - 1) = sn(j, UBound(sn, 2) - 1) + 1
ElseIf sn(j, jj) <> "X" And sn(j, jj) <> "" Then
sn(j, UBound(sn, 2)) = sn(j, UBound(sn, 2)) + 1
End If
Next

If sn(j, UBound(sn, 2)) = 0 Then sn(j, UBound(sn, 2)) = ""
If sn(j, UBound(sn, 2) - 1) = 0 Then sn(j, UBound(sn, 2) - 1) = ""
Next
End With

Sheet3.ListObjects(1).DataBodyRange = sn
End Sub

[Ajannear]

Hi snb,

This is fantastic - There is only one more issue that seems to be plaguing me and I can't seem to find where it is driven from.

The 'Status' column on Cross-Referencing is derived from the Doc Register Page. Each time I run the calc, it overrides the Vlookup formula to paste the value in as a text into the Status column. Seeing as this value is something that is constantly changing, I was hoping to keep the formula in there. Would this possible?

Thanks

[Ajannear]

Hi snb,

I managed to work it out, this has solved al of my issues. you are a star!

Thsnks