VBA Help - Speed up a For Each Statement

[Johnny Thunder]

Hello all,

I have a For Each statement piece of code that adds a value to a column at the end of my report. My current code is processing 30k rows in excel and runs in 40 seconds. I was hoping someone may see a better way to write the code I have in a more efficient way to speed up the run time.

Any ideas are appreciated.

Here is the code:

'----------------------------------------------------------------------------------------
'--- Using the Group List by Titles tag each record with Unique Name
'----------------------------------------------------------------------------------------
Sub GroupTitles()


Dim ws1 As Worksheet, ws2 As Worksheet
Dim Count As String, OriginalTitle As String, GroupTitle As String
Dim ceLL As Range, ceLL2 As Range
Dim LastR1 As Long, LastR2 As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual



Set ws1 = Sheets("Download")
Set ws2 = Sheets("Lookup")


LastR1 = ws1.Range("G" & Rows.Count).End(xlUp).Row
LastR2 = ws2.Range("B" & Rows.Count).End(xlUp).Row


'ws1.Range("O2:O" & LastR1).ClearContents   'Clears the Group column First


For Each ceLL In ws2.Range("B2:B" & LastR2) 'Loops thru the list of Grouped Titles
    If ceLL.Value <> "" Then
        OriginalTitle = ceLL.Value
        GroupTitle = ceLL.Offset(0, 1).Value
    End If


        For Each ceLL2 In ws1.Range("B2:B" & LastR1)    'Loops down the download sheet Column B
            If ceLL2.Value = OriginalTitle Then
                ceLL2.Offset(0, 13).Value = GroupTitle
            Else: ceLL2.Offset(0, 13).Value = ceLL2.Value   'Brings in regular titles into the Grouped Column
            End If
        Next ceLL2


Next ceLL

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

        
End Sub

 

[DanteAmor]

Try the following macro.
Maybe it can be improved if you put a sample with 10 or 15 records per sheet and the result you expect. That way I can understand the process and seek an improvement.

Sub GroupTitles()
  Dim ws1 As Worksheet, ws2 As Worksheet, OriginalTitle As String, GroupTitle As String
  Dim a() As Variant, b() As Variant, c() As Variant, i As Long, j As Long
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set ws1 = Sheets("Download")
  Set ws2 = Sheets("Lookup")
  a = ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Value
  b = ws2.Range("B2:C" & ws2.Range("B" & Rows.Count).End(xlUp).Row).Value
  ReDim c(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(b, 1)
    If b(i, 1) <> "" Then
      OriginalTitle = b(i, 1)
      GroupTitle = b(i, 2)
    End If
    For j = 1 To UBound(a, 1)
      If a(j, 1) = OriginalTitle Then
        c(j, 1) = GroupTitle
      Else
        c(j, 1) = a(j, 1)
      End If
    Next
  Next
  Range("O2").Resize(UBound(a)).Value = c()
  Application.Calculation = xlCalculationAutomatic
End Sub

 

[Johnny Thunder]

Hi Dante,

Thank you for the code you provided.

So this definitely looks waaaaay better than what I came up with. I am having a small issue though that you might know how to fix.

So, when I run the code as is, it seems to not populate the "GroupTitles" Part, but it does do the line Else c(j,1) = a(j,1).

So, I tried actually doing the opposite, I commented out the Else statement and then the code does exactly what I need it to do. I have a funny feeling it may be re-looping the range that it tags with "GroupTitle"

Any Ideas on how to fix? I did clean up the spacing of the code so its easier on the eyes.

Sub GroupTitles()
  
Dim ws1 As Worksheet, ws2 As Worksheet, OriginalTitle As String, GroupTitle As String
Dim a() As Variant, b() As Variant, c() As Variant, i As Long, j As Long


Application.ScreenUpdating = False
  
Set ws1 = Sheets("Download")
Set ws2 = Sheets("Lookup")


a = ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Value
b = ws2.Range("B2:C" & ws2.Range("B" & Rows.Count).End(xlUp).Row).Value
  
        ReDim c(1 To UBound(a), 1 To 1)
            For i = 1 To UBound(b, 1)
                If b(i, 1) <> "" Then
                    OriginalTitle = b(i, 1)
                    GroupTitle = b(i, 2)
                End If
        
        For j = 1 To UBound(a, 1)
            If a(j, 1) = OriginalTitle Then
                c(j, 1) = GroupTitle
            Else
                c(j, 1) = a(j, 1)
            End If
        Next
            Next
        
        Range("O2").Resize(UBound(a)).Value = c()
        
      
        Application.ScreenUpdating = True
        
        MsgBox "All Done"


End Sub

 

[DanteAmor]

So, when I run the code as is, it seems to not populate the "GroupTitles" Part, but it does do the line Else c(j,1) = a(j,1).

So, I tried actually doing the opposite, I commented out the Else statement and then the code does exactly what I need it to do. I have a funny feeling it may be re-looping the range that it tags with "GroupTitle"

Any Ideas on how to fix? I did clean up the spacing of the code so its easier on the eyes.

As I told you to improve the code, I need to understand what you need. And for that you must explain with examples of what you have in your sheets and the expected result.

 

[Peter_SSs]

So, when I run the code as is, it seems to not populate the "GroupTitles" Part, but it does do the line Else c(j,1) = a(j,1).

That isn't surprising since that is exactly what your code from post 1 does too & Dante was just giving you a faster way, which is what you asked for.

This is my suggestion for what I think you want.

Sub Group_Titles()
  Dim d As Object
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  Set ws1 = Sheets("Download")
  Set ws2 = Sheets("Lookup")
  With ws2
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Resize(, 2).Value
  End With
  For i = 1 To UBound(a)
    If Len(a(i, 1)) > 0 Then d(a(i, 1)) = a(i, 2)
  Next i
  With ws1
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a)
      If d.exists(a(i, 1)) Then a(i, 1) = d(a(i, 1))
    Next i
    .Range("O2").Resize(UBound(a)).Value = a
  End With
End Sub

 

[Johnny Thunder]

Hi Peter,

Thanks for chiming in. You proposal looks great but unfortunately the scripting dictionary doesn't seem to work on Excel for Mac, is there a way to modify that bit to make it work for Mac?

 

[Peter_SSs]

.. unfortunately the scripting dictionary doesn't seem to work on Excel for Mac, ..

Suggest that you always include that information in your first post, or thread title, or signature as the more common happening here is that if unstated, we tend to assume a Windows operating system.

In that case, I would like to know
- if the same value can occur more than once in column B of the 'Lookup' sheet? (If 'Yes' I might have more questions about that)
- if the same value can occur more than once in column B of the 'Download' sheet?

 

[Johnny Thunder]

Peter/Dante


I was able to achieve what I needed with a small change to Dante's code (see below)

It seems like the code was re-tagging values that it had already previously tagged so by adding a "if the cell is blank" statement then proceed if not then do nothing and it take care of the issue.

Sub GroupTitles()
  
Dim ws1 As Worksheet, ws2 As Worksheet, OriginalTitle As String, GroupTitle As String
Dim a() As Variant, b() As Variant, c() As Variant, i As Long, j As Long
 
Set ws1 = Sheets("Download")
Set ws2 = Sheets("Lookup")


Application.ScreenUpdating = False


a = ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Value
b = ws2.Range("B2:C" & ws2.Range("B" & Rows.Count).End(xlUp).Row).Value
  
        ReDim c(1 To UBound(a), 1 To 1)
            For i = 1 To UBound(b, 1)
                If b(i, 1) <> "" Then
                    OriginalTitle = b(i, 1)
                    GroupTitle = b(i, 2)
                End If
        
        For j = 1 To UBound(a, 1)
            If a(j, 1) = OriginalTitle Then
                c(j, 1) = GroupTitle
            ElseIf c(j, 1) = "" Then c(j, 1) = a(j, 1)
            End If
        Next
            Next
        
        Range("O2").Resize(UBound(a)).Value = c()
        
MsgBox Prompt:="Updates have been processed", Title:="FINITO!"
              
    End Sub

 

[Peter_SSs]

I was able to achieve what I needed with a small change to Dante's code (see below)

Good news.
What has the 40 second run-time come down to now?

 

[DanteAmor]

Peter/Dante


I was able to achieve what I needed with a small change to Dante's code (see below)

It seems like the code was re-tagging values that it had already previously tagged so by adding a "if the cell is blank" statement then proceed if not then do nothing and it take care of the issue.

The problem of overwriting labels is a problem from your original code. I only transcribed your code, including "errors".


I had to do that code transcript because I don't have the context of your data nor do I have examples of what you need.

If you could give examples of your sheets, I could review the code and improve it.

Initially, I commented to you that the second for is not necessary, that would save a lot of time, but without examples I am blind.