Is lRow slowing my process?

[Big Lar]

This code is used 28 times in my project. While it works, lRow appears to slow the process due to my poor development – many of the sheets have had data in cells well below the current used range.

Some of the sheets run thru Next rCur over 5000 rows during processing. I believe the process could be dramatically faster if the lRow could end at the actual used last row.

Background: The process starts with each formatted sheet cleared of all data. The sheets are then populated with data from a UserForm. The data is dynamic – sometimes there are as few as 10 rows, other times it could be 100 rows or more.

Before I completely replace these worksheets with new unused sheets, can someone suggest some code that stops at the actual last cell used in the current referenced sheet? All of my attempts have proven fruitless.

lRow = rCur.Row
    If lRow > 0 Then

  “Do my stuff”

 Next rCur

 

[mumps]

What is the variable "rCur" represent? It might help if you could post your code and explain in detail in words what you are trying to do.

 

[Richard U]

Try this combination

YOUR CODE

lRow = GetLast(1, ActiveSheet.Cells)

This will reference the function below

Function GetLast(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = GetLast row
' 2 = GetLast column
' 3 = GetLast cell
    Dim lrw As Long
    Dim Lcol As Long

    Select Case choice

    Case 1:
        On Error Resume Next
        GetLast = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        GetLast = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       After:=rng.Cells(1), _
                       lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        Lcol = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        GetLast = rng.Parent.Cells(lrw, Lcol).Address(False, False)
        If Err.Number > 0 Then
            GetLast = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
    If GetLast = 0 Then GetLast = 1
    End Select
End Function

 

[Big Lar]

Thanks for your interest in assisting me. I’m self-taught and tend to get easily lost.

This code is used to populate the Payouts worksheet for my tournaments. Each participant is listed in ColumnB and their winnings for the various “games” are programmatically displayed in adjoining columns.

There are 20 possible game formats included in the “program”.
Sheets("Settings”) provides the references for each competition:

• Game format(s) played today
• Prize money for each format
• Etc.

With a roster of 40-80 participants and every possible game format included, the code can be quite slow…especially when run on a 5 year old laptop with limited RAM and processor.
Considerable debugging has indicated that this and similar procedures to be the cause of the s-l-o-w-s.

The slowness issue might be resolved by eliminating the excessive Ranges that my rookie-self filled with data during construction of the workbook. I didn’t realize that data filled cells A:5000-Z:5200 would establish the END of the used cells – and, that deleting that data would not change the END!

Programmatically solving this would also eliminate the tedious task of replacing each worksheet with a "fresh" sheet.

Sub Payouts()
     
Const msGROSSSheet As String = "GROSS"
Const msNETSheet As String = "NET"
Const msSettingsSheet As String = "Settings"
Const msSkinsG1Sheet As String = "SkinsG1"
Const msSkinsG2Sheet As String = "SkinsG2"
Const msSkinsG3Sheet As String = "SkinsG3"
Const msSkinsG4Sheet As String = "SkinsG4"
Const msSkinsN1Sheet As String = "SkinsN1"
Const msSkinsN2Sheet As String = "SkinsN2"
Const msSkinsN3Sheet As String = "SkinsN3"
Const msSkinsN4Sheet As String = "SkinsN4"
Const msPAYOUTSSheet As String = "PAYOUTS"
 
Dim iCol As Integer
Dim lRow1 As Long
Dim lRow As Long
Dim objNames As Object
Dim rCur As Range
Dim sKey As String
Dim wsPAYOUTS As Worksheet, wsSettings As Worksheet, wsGROSS As Worksheet, wsNET As Worksheet, wsSkinsG1 As Worksheet, wsSkinsG2 As Worksheet, wsSkinsG3 As Worksheet, wsSkinsG4 As Worksheet, wsSkinsN1 As Worksheet, wsSkinsN2 As Worksheet, wsSkinsN3, wsSkinsN4 As Worksheet
 
Set objNames = Nothing
Set objNames = CreateObject("Scripting.Dictionary")
Set wsPAYOUTS = Sheets(msPAYOUTSSheet)
 
 
'—Record GROSS winnings to PAYOUTS—
If Sheets("Settings").[A1] = 1 Then
Set wsGROSS = Sheets(msGROSSSheet)
 
'—Populate names dictionary –
For Each rCur In Intersect(wsPAYOUTS.UsedRange, wsPAYOUTS.Columns("B"))
 
    lRow = rCur.Row
    If lRow > 1 Then
        sKey = Trim$(CStr(rCur.Value))
        If sKey <> "" Then
            On Error Resume Next
            objNames.Add Key:=sKey, Item:=lRow
            On Error GoTo 0
        End If
    End If
Next rCur
 
'—Fill Data—
iCol = wsPAYOUTS.Cells(1, Columns.Count).End(xlToLeft).Column + 3
wsPAYOUTS.Cells(1, iCol).Value = "Overall" & vbCrLf & "GROSS" & vbCrLf & "SKINS"
wsPAYOUTS.Cells(2, iCol).Value = "$" & Sheets("Settings").[E7].Value & " Ea"
For Each rCur In Intersect(wsGROSS.UsedRange, wsGROSS.Columns("BP"))
 
‘—Debugging shows this to be where the slowdown occurs. lRow can be in the thousands when the procedure finally moves on to the following procedure.—
    lRow = rCur.Row  
    If lRow > 0 Then
        sKey = Trim$(CStr(rCur.Value))
        If sKey <> "" Then
            lRow1 = 0
            On Error Resume Next
            lRow1 = objNames.Item(sKey)
            On Error GoTo 0
            If lRow1 = 0 Then
                lRow1 = wsPAYOUTS.Cells(Rows.Count, "A").End(xlUp).Row + 1
                wsPAYOUTS.Range("B" & lRow1).Value = sKey
               
            End If
            wsPAYOUTS.Cells(lRow1, iCol).Value = wsGROSS.Range("BQ" & lRow).Value
        End If
    End If
Next rCur
 
objNames.RemoveAll
Set objNames = Nothing
Else
End If
‘—Repeat this for each game format and it’s associated worksheet.

 

[rlv01]

Instead of this

        For Each rCur In Intersect(wsGROSS.UsedRange, wsGROSS.Columns("BP"))
            '—Debugging shows this to be where the slowdown occurs. lRow can be in the thousands when the procedure finally moves on to the following procedure.—

maybe something like this

        Dim ColRange As Range
        With wsGROSS
            Set ColRange = .Range("BP1:BP" & .Range("BP" & .Rows.Count).End(xlUp).Row)
        End With
        For Each rCur In ColRange
            '—Debugging shows this to be where the slowdown occurs. lRow can be in the thousands when the procedure finally moves on to the following procedure.—

 

[Big Lar]

Thanks rlv01!
I've adapted your suggestion. Works perfectly!