My project’s final routine fills data from several sheets to two worksheets.
This code produces the desired results, but requires considerable time to complete the task.
When debugging, I find the routines expand the two worksheets to Rows 1048576 even though data rows may only exist to Row 500. I’m unsure if this is the cause of the “slow procedure” but, my tests indicate this is the case…the procedure requires the same time to complete regardless of the number of data rows on the sheets.
I’m wondering if modifying the code to reduce the range to Row 500 might speed the process? And, if so, how would that modification be accomplished?
This code produces the desired results, but requires considerable time to complete the task.
When debugging, I find the routines expand the two worksheets to Rows 1048576 even though data rows may only exist to Row 500. I’m unsure if this is the cause of the “slow procedure” but, my tests indicate this is the case…the procedure requires the same time to complete regardless of the number of data rows on the sheets.
I’m wondering if modifying the code to reduce the range to Row 500 might speed the process? And, if so, how would that modification be accomplished?
Code:
'--Record weekly winnings to MONEYLIST --
Const msMONEYLISTSheet As String = "MONEYLIST"
Const msPAYOUTSSheet As String = "PAYOUTS"
Const msPLAYERSSheet As String = "PLAYERS"
Dim iCol As Integer
Dim lRow As Long, lRow1 As Long
Dim objNames As Object
Dim rCur As Range
Dim sKey As String
Dim wsPAYOUTS As Worksheet, wsMONEYLIST As Worksheet, wsPLAYERS As Worksheet
Set objNames = Nothing
Set objNames = CreateObject("Scripting.Dictionary")
Set wsMONEYLIST = Sheets(msMONEYLISTSheet)
Set wsPAYOUTS = Sheets(msPAYOUTSSheet)
'--Populate names dictionary --
For Each rCur In Intersect(wsMONEYLIST.UsedRange, wsMONEYLIST.Columns("C"))
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
'-- Store Date to first empty column --
iCol = wsMONEYLIST.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsMONEYLIST.Cells(1, iCol).Value = Format(Date, "dd-mmm")
For Each rCur In Intersect(wsPAYOUTS.UsedRange, wsPAYOUTS.Columns("B"))
lRow = rCur.Row
If lRow > 2 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 = wsMONEYLIST.Cells(Rows.Count, "C").End(xlUp).Row + 1
wsMONEYLIST.Range("C" & lRow1).Value = sKey
'objNames.Add Key:=sKey, Item:=lRow1
End If
wsMONEYLIST.Cells(lRow1, iCol).Value = wsPAYOUTS.Range("C" & lRow).Value
End If
End If
Next rCur
objNames.RemoveAll
Set objNames = Nothing
'--Totals player's accumulated winnings --
Dim Column_F_F As Long
Dim ws As Worksheet
Set ws = Sheets("MONEYLIST")
Column_F_F = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("F2:F" & ws.Range("A" & Rows.Count).End(xlUp).Row).Formula = "=SUM(H2:BG2)"
ws.Calculate
ws.Columns("F:F").Value = ws.Columns("F:F").Value
'--Counts player's total games played --
Dim Column_G_G As Long
Set ws = Sheets("MONEYLIST")
Column_G_G = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("G2:G" & ws.Range("A" & Rows.Count).End(xlUp).Row).Formula = "=COUNT(H2:BG2)"
ws.Calculate
ws.Columns("G:G").Value = ws.Columns("G:G").Value
ws.Columns("A:BG").AutoFit
'--Saves backup copies of MONEYLIST --
Sheets("MONEYLIST").Copy
ActiveWorkbook.SaveAs Filename:="C:\SKINS PRO\Data\Moneylist.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:="C:\SPDB13\DB\MoneyList.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
'--Records ADJUSTED gross scores to PLAYERS --
Const msADJSheet As String = "ADJ"
Dim wsADJ As Worksheet
Set objNames = Nothing
Set objNames = CreateObject("Scripting.Dictionary")
Set wsADJ = Sheets(msADJSheet)
Set wsPLAYERS = Sheets(msPLAYERSSheet)
'--Populate names dictionary --
For Each rCur In Intersect(wsPLAYERS.UsedRange, wsPLAYERS.Columns("C"))
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
'-- Store Date --
iCol = wsPLAYERS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsPLAYERS.Cells(1, iCol).Value = Format(Date, "dd-mmm")
For Each rCur In Intersect(wsADJ.UsedRange, wsADJ.Columns("A"))
lRow = rCur.Row
If lRow > 2 Then
sKey = Trim$(CStr(rCur.Value))
If sKey <> "" Then
lRow1 = 1
On Error Resume Next
lRow1 = objNames.Item(sKey)
On Error GoTo 0
If lRow1 = 0 Then
lRow1 = wsPLAYERS.Cells(Rows.Count, "C").End(xlUp).Row + 1
wsPLAYERS.Range("C" & lRow1).Value = sKey
objNames.Add Key:=sKey, Item:=lRow1
End If
wsPLAYERS.Cells(lRow1, iCol).Value = wsADJ.Range("V" & lRow).Value
End If
End If
Next rCur
objNames.RemoveAll
Set objNames = Nothing
Sheets("Players").Select
'--Averages Player's scores before saving --
Dim Column_K_K As Long
Set ws = Sheets("PLAYERS")
Column_K_K = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("K2").FormulaArray = "=IF(COUNT(L2:BX2),AVERAGE(SMALL(INDEX(2:2,LARGE(IF(ISNUMBER(L2:BX2),COLUMN(L2:BX2))," & "MIN(COUNT(L2:BX2),Settings!$A$32))):BX2,ROW(INDIRECT(""1:""&MIN(COUNT(L2:BX2),Settings!$A$31))))),"""")"
ws.Calculate
ws.Range("K2").Select
With Selection
.AutoFill Destination:=ws.Range("K2:K" & ws.Range("A" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
End With
ws.Columns("K:K").Value = ws.Columns("K:K").Value
Dim Column_D_D As Long
Set ws = Sheets("PLAYERS")
Column_D_D = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("D2:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Formula = "=ROUND((((K2-COURSE!$X$1)*113)/COURSE!$Y$1),0)"
ws.Calculate
ws.Columns("D:D").Value = ws.Columns("D:D").Value
Dim Column_E_E As Long
Set ws = Sheets("PLAYERS")
Column_E_E = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("E2:E" & ws.Range("A" & Rows.Count).End(xlUp).Row).Formula = "=COUNT(L2:JZ2)"
ws.Calculate
ws.Columns("E:E").Value = ws.Columns("E:E").Value
ws.Columns("A:BG").AutoFit
></o
