How to optimise counting in loops

Hi, so I have a macro that takes an hour to process and I have an idea why but I do not know how to optimise it. If anyone can, can you please help?

Thank you!

Sub Example4()
Dim mcco As Worksheet, mcfc As Worksheet, mcfb As Worksheet, mcfv As Worksheet
Dim CVTR As Long, FCBR As Long, FBCC As Long, FCMC As Long, ii As Long, i As Long, j As Long, k As Long, l As Long, s As Long
Dim FTVA(), FTNA, MLNA
Dim CVFD As Collection, CVMN As Collection, CVFP As Collection, CVFN As Collection, CVM1 As Collection, CVM2 As Collection
Dim XD
Dim pattern As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set mcco = Workbooks("PERSONAL.xlsb").Worksheets("Converter")
Set mcfc = Workbooks("PERSONAL.xlsb").Worksheets("Files Count")
Set mcfb = Workbooks("PERSONAL.xlsb").Worksheets("Files BSA Converter")
  
CVTR = mcco.Cells(Rows.Count, 2).End(xlUp).Row 'Currently at 400439
FCBR = mcfc.Cells(Rows.Count, 2).End(xlUp).Row - 1 'Currently at 870
FBCC = Application.WorksheetFunction.Max(mcfc.Columns(6)) + 1 'Currently at 5
FCMC = mcfc.Cells(1, Columns.Count).End(xlToLeft).Column 'Currently at 41

Workbooks("PERSONAL.xlsb").Worksheets("Converter").Activate

Set CVFD = New Collection
Set CVMN = New Collection
Set CVFP = New Collection
Set CVFN = New Collection
Set CVM1 = New Collection
Set CVM2 = New Collection

For i = 1 To CVTR
    CVFD.Add mcco.Cells(i, 1).Value
    CVMN.Add mcco.Cells(i, 2).Value
    CVFP.Add mcco.Cells(i, 3).Value
    CVFN.Add mcco.Cells(i, 4).Value
    CVM1.Add mcco.Cells(i, 2).Value & " || " & mcco.Cells(i, 3).Value
    CVM2.Add mcco.Cells(i, 2).Value & " || " & mcco.Cells(i, 4).Value
Next i

MLNA = Application.Transpose(Range(mcfc.Cells(1, 2), mcfc.Cells(FCBR, 2)))

j = 1
With mcfc
    FTNA = Application.Transpose(.Range(.Cells(1, 1), .Cells(1, FCMC)).Value)
    For i = 3 To FCMC
        ReDim Preserve FTVA(j)
        FTVA(j) = Mid(FTNA(i, 1), Application.Find("(", FTNA(i, 1)) + 1, Application.Find(")", FTNA(i, 1)) - Application.Find("(", FTNA(i, 1)) - 1)
        j = j + 1
    Next i
End With
    
    For j = 1 To FCBR
        c = 0
        For k = 3 To 7
            For l = 2 To CVTR
            pattern = "*" & MLNA(j) & "*" & FTVA(k) & ""
            If CVM2.Item(l) Like pattern Then
                mcfc.Cells(j + 1, k).Value = c + 1
                c = mcfc.Cells(j + 1, k).Value
            End If
            Next l
            Stop
        Next k
    Next j

Stop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

End Sub

Come on Goede7...Get with the program...lol

By now you should know that an sample upload speaks a thousand words...

Difficult to know exactly what your macri is doing, but are you suer you shoud be looping a macro anyway. This subject really should be a FAQ. I see it time and time again and looping just isn't the best way of doing many of these things.

Whenever you find yourself creating looping code stop and think is this really necessary? Most of the time it isn't. Loops are inherently slow when they have to jump back and forth between VBA and the Excel application - there's a big time overhead at each pass through the loop.

The fastest, most efficient and elegant way for this sort of stuff is to use an Autofilter to filter the rows you're interested in.
Then use syntax like

Range("your_range").SpecialCells(xlCellTypeVisible).Copy

then paste to your destination cell.

This uses just one Copy / Paste instruction rather than many if you're looping through many cells.

You may need a heper column that contains a function which will identify the rows you're interested in so taht you can use the Autofilter. te macro could of course generate that helper column.

Originally Posted by Geode7

Once I manage to figure out how to upload the unloadable file, then you will realise why.

What's the size of your file. We don't need zillions of rows a representative sample would do.
The forum permits up to 9.6 Mb for .xlsb files rather than the ~1.2Mb for the rest


To upload a file click the Go Advanced button at the foot of your post, look underneath the post area for the Manage Attachments section and take it from there.

I'm not sure how many iteration you are performing at below section. But in general avoid use of Redim Preserve. Adding item to collection will be much faster than using Redim Preserve at each iteration.

    For i = 3 To FCMC
        ReDim Preserve FTVA(j)
        FTVA(j) = Mid(FTNA(i, 1), Application.Find("(", FTNA(i, 1)) + 1, Application.Find(")", FTNA(i, 1)) - Application.Find("(", FTNA(i, 1)) - 1)
        j = j + 1
    Next i

Though difference wouldn't be significant unless you have 100k loop iteration or more (at 100k iteration, difference is about 1/2 sec) for simple loop.
Also, consider using Instr() vba function rather than Application.Find.

So, I tried other macros and this works far faster. However it still takes 1 and a half hours to complete it. Is there a way to optimise this loop?

Sub COUNTINGFILES()

    For i = 2 To FCBR
        For j = 3 To 7
            YD = "=COUNTIFS(" + CVR1.Address(External:=True) + ",""" & MLNA(i) & """," + CVR3.Address(External:=True) + ",""*""&""" & FTVA(j) & """, " + CVR2.Address(External:=True) + ", ""<>*\*"")"
            mcfc.Cells(i, j).Value = YD
            mcfc.Cells(i, j).Value = mcfc.Cells(i, j).Value
        Next j
    Next i
    

FBCC = Application.WorksheetFunction.Max(mcfc.Columns(6)) + 1
MBSA = WorksheetFunction.Application.Transpose(Range(mcfb.Cells(1, 1), mcfb.Cells(FCBR, FBCC)))
    
    For i = 2 To FCBR
        s = 0
        For j = 8 To 10
            For k = 2 To FBCC
                ZD = "=COUNTIFS(" + CVR1.Address(External:=True) + ",""" & MBSA(k, i) & """," + CVR3.Address(External:=True) + ",""*""&""" & FTVA(j) & """)"
                mcfc.Cells(i, j).Value = ZD
                s = s + mcfc.Cells(i, j).Value
                mcfc.Cells(i, j).Value = s
            Next k
        Next j
    Next i

End Sub