I have few reports to create everyday, based on a DB of more than 1 500 000 Lines.... 2 of my modules are really slow, and I suppose this come from a loop I added for 50 000 lines.
I do simple VBA since years, however I don't know how I could speed it up. Any chances you can help with this? Please
MasterLastRow = WS_Mast_QCF.Cells(Rows.Count, 2).End(xlUp).Row
Set LibDisc = WB_Master.Worksheets("Lib_Disc").Range("A2:C100")
Set LibSS = WB_Master.Worksheets("Lib_SS").Range("D2:G10000")
Set LibMod = WB_Master.Worksheets("Lib_Mod").Range("B2:G1000")
For n = 2 To MasterLastRow
On Error Resume Next
Modu = WS_Mast_QCF.Range("B" & n).Value
SS = WS_Mast_QCF.Range("E" & n).Value
Disc = WS_Mast_QCF.Range("G" & n).Value
QCFStatus = WS_Mast_QCF.Range("N" & n).Value
With Application.WorksheetFunction
WS_Mast_QCF.Range("A" & n) = .VLookup(Modu, LibMod, 6, False)
WS_Mast_QCF.Range("C" & n) = .VLookup(SS, LibSS, 3, False)
WS_Mast_QCF.Range("D" & n) = .VLookup(SS, LibSS, 4, False)
WS_Mast_QCF.Range("F" & n) = .VLookup(SS, LibSS, 2, False)
WS_Mast_QCF.Range("G" & n) = .VLookup(Disc, LibDisc, 3, False)
End With
If SS = "" Then
WS_Mast_QCF.Range("C" & n & ":F" & n) = "TBD"
End If
' QCF Status Treatment
Select Case QCFStatus
Case Is = "Inspection Step", "Open RFI"
WS_Mast_QCF.Range("H" & n).Value = "Pending"
WS_Mast_QCF.Range("N" & n).Value = ""
Case Is <> "Inspection Step", "Open RFI"
WS_Mast_QCF.Range("H" & n).Value = "Done"
End Select
Next n
When developing in Excel-VBA there are several rules that you should follow for best performance as I have outlined in this previous answer (https://stackoverflow.com/a/19167804/109122). To summarize it, minimize your VBA's interactions with the Excel model/spreadsheet, primarily by using Range-Array copying instead of reading and writing individual cells and/or ranges.
Additionally, as I mentioned in my comment above, generally the way that you optimize loops is to find ways to move work outside of the loop.
Combining these two I have derived the code below as one way to do this. Without your data/spreadsheet I cannot test it, but it should be pretty close to working correctly and it will be many times faster. Note that this code is significantly longer primarily because I have include the Dim statements and because I have retained some of the intermediate steps (like the Lib* variables) to make it easier to see how it relates to the original code.
MasterLastRow = WS_Mast_QCF.Cells(Rows.Count, 2).End(xlUp).Row
Set LibDisc = WB_Master.Worksheets("Lib_Disc").Range("A2:C100")
Set LibSS = WB_Master.Worksheets("Lib_SS").Range("D2:G10000")
Set LibMod = WB_Master.Worksheets("Lib_Mod").Range("B2:G1000")
' Copy the lookup ranges values into arrays
Dim DiscA() As Variant, SSA() As Variant, ModA() As Variant
DiscA = LibDisc.Value
SSA = LibSS.Value
ModA = LibMod.Value
' Make dictionaries of VLookup indexes
Dim VlookupMod As Scripting.Dictionary 'note: must add "Microsoft Sripting Runtime" in Add Tools References
Dim VlookupSS As Scripting.Dictionary
Dim VlookupDisc As Scripting.Dictionary
Set VlookupDisc = BuildVLookupDictionary(DiscA)
Set VlookupMod = BuildVLookupDictionary(ModA)
Set VlookupSS = BuildVLookupDictionary(SSA)
' Copy the read/writeable area into two arrays
Dim QcfA() As Variant, QCFStatusA() As Variant
QcfA = WS_Mast_QCF.Range("A1:H50000").Value
QCFStatusA = WS_Mast_QCF.Range("N1:N50000").Value
' Define some convenient column indexes
Const Ax = 1: Const Bx = 2: Const Cx = 3: Const Dx = 4: Const Ex = 5
Const Fx = 6: Const Gx = 7: Const Hx = 8
' loop through every row
For n = 2 To MasterLastRow
On Error Resume Next
Modu = QcfA(n, Bx)
SS = QcfA(n, Ex)
Disc = QcfA(n, Gx)
QCFStatus = QCFStatusA(n, 1)
QcfA(n, Ax) = ModA(VlookupMod(Modu), 6)
QcfA(n, Cx) = SSA(VlookupSS(SS), 3)
QcfA(n, Dx) = SSA(VlookupSS(SS), 4)
QcfA(n, Fx) = SSA(VlookupSS(SS), 2)
QcfA(n, Gx) = DiscA(VlookupDisc(Disc), 3)
If SS = "" Then
QcfA(n, Cx) = "TBD"
QcfA(n, Dx) = "TBD"
QcfA(n, Ex) = "TBD"
QcfA(n, Fx) = "TBD"
End If
' QCF Status Treatment
Select Case QCFStatus
Case Is = "Inspection Step", "Open RFI"
QcfA(n, Hx) = "Pending"
QCFStatusA(n, 1) = ""
Case Is <> "Inspection Step", "Open RFI"
QcfA(n, Hx) = "Done"
End Select
Next n
' Copy the modified arrays back into their ranges
WS_Mast_QCF.Range("A1:H50000").Value = QcfA
WS_Mast_QCF.Range("N1:N50000").Value = QCFStatusA
This uses a function that I wrote to simplify building the dictionaries that replace the VLookup calls:
Function BuildVLookupDictionary(ValuesArray() As Variant) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
'ignore duplicate key errors
On Error Resume Next
For r = 1 To UBound(ValuesArray, 1)
dict.Add ValuesArray(r, 1), r
Next r
On Error GoTo 0
Set BuildVLookupDictionary = dict
End Function