VBA Help - For Each Loop with Large Data Set - Need an Alternative Loop

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
693
Office Version
  1. 2016
Platform
  1. MacOS
Hello everyone,

I am working on a project that will at some point get migrated into an actual database but at the moment is being managed in excel and the data has gotten really large. The Row count of the report has now hit over 300k+ across 12 columns. Unfortunately there is no way to trim off old data so I am stuck with this report as is.

Need:
I have a macro that loops thru one column and looks for a specific "Type" and if found revises one column value with another value and if it finds anything other than a specific "Type" if will also process a revision. Currently, the only way that seems to work for me with my limited knowledge of large loops is a For Each statement but I am hoping someone can think of a better/faster way to do this that went get an 'Overflow' error due to the high data set.

Code currently takes 8min to run so hoping to get that time down to under a minute if possible. Any help is appreciated.

*I am also doing this on a mac version of excel which does not have the ActiveX module active or allow for creating libraries but most all other codes work without issues.

Here is the current code:

VBA Code:
Sub AlterDownload()

Dim ws1         As Worksheet, ws2 As Worksheet
Dim LastR1     As String, LastR2 As Long
Dim Count      As String
Dim ceLL        As Range
Dim r               As Long

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

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

For Each ceLL In ws1.Range("G2:G" & LastR1)
    r = ceLL.Row
        If ceLL.Value = "EpisodeVersion" Then
                ws1.Range("P" & r).Value = ws1.Range("C" & r).Value
        Else
            ws1.Range("P" & r).Value = ws1.Range("A" & r).Value
        End If
Next ceLL


End sub
 
Last edited:

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Ok, I put this code together with the idea to use an array to speed things up. You also have included some code that is not used in the subroutine that you posted, so I commented those lines out. I also included some other lines that, when you are dealing with large amounts of data, they can speed things up also.

I have not tried this code, so let us know how it works out for you. It should work, at least in my head:

VBA Code:
Sub AlterDownload()
'
    Dim gRowCounter     As Long                                     ' Added
    Dim LastR1          As Long                                     ' Added
''    Dim r               As Long                                     ' Replaced, No longer needed
''    Dim LastR2          As Long                                     ' Not used in this subroutine
''    Dim ceLL            As Range                                    ' Replaced, No longer needed
''    Dim Count           As String                                   ' Don't do that, it is a reserved word
''    Dim LastR1          As String                                   ' This should be 'As Long'
    Dim gColumnArray()  As Variant                                  ' Added
    Dim ws1             As Worksheet
''    Dim ws2             As Worksheet                                ' Not used in this subroutine
'
'
    Application.ScreenUpdating = False                              ' Added
    Application.Calculation = xlCalculationManual                   ' Added
    Application.EnableEvents = False                                ' Added
'
    Set ws1 = Sheets("Download")
''    Set ws2 = Sheets("Lookup")                                      ' Not used in this subroutine
'
    LastR1 = ws1.Range("F" & Rows.Count).End(xlUp).Row
''    LastR2 = ws2.Range("B" & Rows.Count).End(xlUp).Row             ' Not used in this subroutine
'
'---------------------------------------------------------------------------------------------------
''    For Each ceLL In ws1.Range("G2:G" & LastR1)                   ' Code section that is slow
''        r = ceLL.Row
'
''        If ceLL.Value = "EpisodeVersion" Then
''            ws1.Range("P" & r).Value = ws1.Range("C" & r).Value
''        Else
''            ws1.Range("P" & r).Value = ws1.Range("A" & r).Value
''        End If
''    Next ceLL
'---------------------------------------------------------------------------------------------------
'
    gColumnArray = ws1.Range("G2:G" & LastR1).Value                 ' This will load values into a one based array ;) ie. gColumnArray(1,1) gColumnArray(2,1)
'
    For gRowCounter = 1 To UBound(gColumnArray)
        If gColumnArray(gRowCounter, 1) = "EpisodeVersion" Then                                 ' Check G2,G3,G4, etc for "EpisodeVersion", If Found then
            ws1.Range("P" & gRowCounter + 1).Value = ws1.Range("C" & gRowCounter + 1).Value     '   Set P2,P3,P4, etc to value found in C2,C3,C4, etc
        Else                                                                                    ' Else
            ws1.Range("P" & gRowCounter + 1).Value = ws1.Range("A" & gRowCounter + 1).Value     '   Set P2,P3,P4, etc to value found in A2,A3,A4, etc
        End If
    Next
'
    Application.EnableEvents = True                                 ' Added
    Application.Calculation = xlCalculationAutomatic                ' Added
    Application.ScreenUpdating = True                               ' Added
End Sub


Code without all of the lines that I commented out = :

VBA Code:
Sub AlterDownload()
'
    Dim gRowCounter     As Long                                     ' Added
    Dim LastR1          As Long                                     ' Added
    Dim gColumnArray()  As Variant                                  ' Added
    Dim ws1             As Worksheet
'
'
    Application.ScreenUpdating = False                              ' Added
    Application.Calculation = xlCalculationManual                   ' Added
    Application.EnableEvents = False                                ' Added
'
    Set ws1 = Sheets("Download")
'
    LastR1 = ws1.Range("F" & Rows.Count).End(xlUp).Row
'
    gColumnArray = ws1.Range("G2:G" & LastR1).Value                 ' This will load values into a one based array ;) ie. gColumnArray(1,1) gColumnArray(2,1)
'
    For gRowCounter = 1 To UBound(gColumnArray)
        If gColumnArray(gRowCounter, 1) = "EpisodeVersion" Then                                 ' Check G2,G3,G4, etc for "EpisodeVersion", If Found then
            ws1.Range("P" & gRowCounter + 1).Value = ws1.Range("C" & gRowCounter + 1).Value     '   Set P2,P3,P4, etc to value found in C2,C3,C4, etc
        Else                                                                                    ' Else
            ws1.Range("P" & gRowCounter + 1).Value = ws1.Range("A" & gRowCounter + 1).Value     '   Set P2,P3,P4, etc to value found in A2,A3,A4, etc
        End If
    Next
'
    Application.EnableEvents = True                                 ' Added
    Application.Calculation = xlCalculationAutomatic                ' Added
    Application.ScreenUpdating = True                               ' Added
End Sub
 
Upvote 0
@Johnny Thunder
Not sure why have 'Set ws2 = Sheets("Lookup")' but you don't use it.
Try this (I didn't test it because I have no data to test):

VBA Code:
Sub a1178366a()
'https://www.mrexcel.com/board/threads/vba-help-for-each-loop-with-large-data-set-need-an-alternative-loop.1178366/
Dim ws1         As Worksheet, ws2 As Worksheet
Dim LastR1     As String, LastR2 As Long
Dim Count      As String
Dim ceLL        As Range
Dim r               As Long
Dim VA, VC, VG, VP

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

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

VP = ws1.Range("P2:P" & LastR1)
VA = ws1.Range("A2:A" & LastR1)
VC = ws1.Range("C2:C" & LastR1)
VG = ws1.Range("G2:G" & LastR1)

For i = 1 To UBound(VG, 1)
    If VG(i, 1) = "EpisodeVersion" Then
        VP(i, 1) = VC(i, 1)
    Else
        VP(i, 1) = VA(i, 1)
    End If
Next


ws1.Range("P2").Resize(UBound(VP, 1), 1) = VP

End Sub
 
Upvote 0
Another option, no loops
VBA Code:
Sub johnnyThunder()
With Sheets("Download")
   With .Range("P2:P" & .Range("F" & Rows.Count).End(xlUp).Row)
      .Value = .Worksheet.Evaluate("if(" & .Offset(, -9).Address & "=""EpisodeVersion""," & .Offset(, -13).Address & "," & .Offset(, -15).Address & ")")
   End With
End With
End Sub
 
Upvote 0
Glad we could help & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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
Back
Top