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

AusSteelMan

Board Regular
Joined
Sep 4, 2009
Messages
208
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.

Code:
     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
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,881
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Code:
     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...
Code:
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

Board Regular
Joined
Sep 4, 2009
Messages
208
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
 

AusSteelMan

Board Regular
Joined
Sep 4, 2009
Messages
208
G'day Rick,

Thanks very much for showing continued interest.

Here is the UDF.

Code:
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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,016
Messages
5,834,956
Members
430,330
Latest member
drAli77

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top