1 Attachment(s)
Slow Calculation of Sum Row
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.
Code:
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:
Code:
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
