Can this For Each Next loop be restructured to make the execution faster

[AusSteelMan]

Hi everyone,

Below is a portion of code from a sub from a large worksheet table (~75000 rows A:BB columns).

I currently select a range manually, then run the sub.

     For Each cell In rng        
        cell.Formula = "=concatif([Material Number],[@[Material Number]],[No_at_Loc],CHAR(10))"
        cell.Copy
        cell.PasteSpecial xlPasteValues
     Next cell

I ended up with this since Excel kept "Not Responding" when letting the table automatically fill and calculate.

As can be seen, the formula I require is a UDF.
This UDF interrogates the entire "Material Number" column to check for the "Material Number" from that particular row, in order to then return concatenated text from the "No_at_Loc" column with CHAR(10) as a separator.
I say this only to inform you that this calculation is time consuming due to the number of rows in the "Material Number" column it is checking. Basically it is a SUMIF for text, hence ConcatIf.

I have found it also takes a very long time for the worksheet to recalculate with such a hungry UDF, hence the Paste Values action. I already have the sheet in manual calculation to prevent lengthy delays while it recalcs without me wanting it to. Also, I don't need it to be live information. Once it has calculated I am happy for it to be text anyway.

It is taking around 0.8 seconds per cell to complete. So for the 75000 odd cells I need to do it will take around 17 hours. I am OK with this (it can run overnight) so long as it doesn't crash. I do get "not responding" come up on the VBA editor (and sometimes the Excel worksheet), but Excel keeps on chugging on anyway, eventually giving me a result (around 15 mins for around 1000 cells).

So my question to you good folk: is there a better method for performing this loop that is more efficient?
(this is as much for my education as it is for my workbook)

Many thanks for considering my problem and for any help you may provide.

Cheers,
Darren

 

[Rick Rothstein]

     For Each cell In rng        
        cell.Formula = "=concatif([Material Number],[@[Material Number]],[No_at_Loc],CHAR(10))"
        cell.Copy
        cell.PasteSpecial xlPasteValues
     Next cell

Do you really need a loop? Why can't you just do this...

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rng.Formula = "=concatif([Material Number],[@[Material Number]],[No_at_Loc],CHAR(10))"
Rng.Value = Rng.Value
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

 

[AusSteelMan]

Thanks Rick.

It seems the majority of my time is in the ConcatIf UDF. That said, by making your suggested changes, the time has reduced from 0.8 seconds/cell to 0.72 seconds/cell. Over the remaining 70,000 cells I have to do, that time saving will total to about 1.55 hours!

I always have a reservation about the loop and thought the was other ways (since there is always is another way as this board demonstrates every day).

Many thanks again.
Darren

 

[Rick Rothstein]

It seems the majority of my time is in the ConcatIf UDF.

In that case, show us the code for it... maybe we can find a way to hurry it along some.

 

[AusSteelMan]

G'day Rick,

Thanks very much for showing continued interest.

Here is the UDF.

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
                            Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
    Dim i As Long, j As Long
    With compareRange.Parent
        Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
    End With
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                                stringsRange.Column - compareRange.Column)
    
        For i = 1 To compareRange.Rows.Count
            For j = 1 To compareRange.Columns.Count
                If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                    If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                        ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
                    End If
                End If
            Next j
        Next i
        ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
    End Function

Cheers,
Darren