ItalianPlatinum
Well-known Member
- Joined
- Mar 23, 2017
- Messages
- 857
- Office Version
- 365
- 2019
- Platform
- Windows
Hello - My current code is working with a lot of data. So I had to break it into 18 sheets so excel could handle the size. But I am getting crushed when I set formulas for my analysis. Does anyone have any tips they could suggest that could help reduce this system strain? One area is I am setting Countifs D:D, E:E, M:M but I don't know the last row for each sheet to set it dynamic for each sheet within the formula. I think that takes up a lot of resources. it took 9 minutes with that commented out, see the below.
VBA Code:
Option Explicit
Sub RUN()
Dim rws As Long
Dim F$, RUN As Date, REQDATE As Date, VIEWW, TMATCH, FILTER, Start, ENDD, Duration
Dim WsExec As Worksheet, WsSum As Worksheet, WsSec As Worksheet, WsCus As Worksheet, Ws0 As Worksheet, Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet, Ws5 As Worksheet, Ws6 As Worksheet, Ws7 As Worksheet, Ws8 As Worksheet, Ws9 As Worksheet, WsA As Worksheet, WsG As Worksheet, WsH As Worksheet, WsL As Worksheet, WsM As Worksheet, WsN As Worksheet, WsP As Worksheet, WsV As Worksheet, WsY As Worksheet
Dim lr As Long, lr1 As Long
Dim chk
Dim wsForSheet As Worksheet
Dim loopRow As Long
Dim lastRow As Long
Dim sheetFilter As String
Dim lastSecurityRow As Long
Dim RNGFilter
Dim i As Long
Dim SheetName As String
Application.ScreenUpdating = False
Application.EnableEvents = False
'set shortcut for worksheets
Set WsExec = Sheets("Execution")
Set WsSum = Sheets("Summary")
Set WsSec = Sheets("Sec")
Set WsCus = Sheets("Cus")
Set Ws0 = Sheets("0")
Set Ws1 = Sheets("1")
Set Ws2 = Sheets("2")
Set Ws3 = Sheets("3")
Set Ws4 = Sheets("4")
Set Ws5 = Sheets("5")
Set Ws6 = Sheets("6")
Set Ws7 = Sheets("7")
Set Ws8 = Sheets("8")
Set Ws9 = Sheets("9")
Set WsA = Sheets("A")
Set WsG = Sheets("G")
Set WsH = Sheets("H")
Set WsL = Sheets("L")
Set WsM = Sheets("M")
Set WsN = Sheets("N")
Set WsN = Sheets("P")
Set WsV = Sheets("V")
Set WsY = Sheets("Y")
'Set Ranges
Fund = WsExec.Range("F")
RUN = WsExec.Range("Run")
VIEWW = WsExec.Range("VIEWW")
Start = WsExec.Range("START")
ENDD = WsExec.Range("ENDD")
Duration = WsExec.Range("DURATION")
TMATCH = WsExec.Range("TMATCH")
REQDATE = WsExec.Range("REQDATE")
FILTER = WsCus.Range("FILTER")
'clear and set filters
With WsExec
.Unprotect
.Range("C6:C8").Cells.ClearContents
.Range("Start") = Time
End With
With WsCus
.Cells.ClearContents
.Range("A:A").NumberFormat = "@"
End With
With WsSec
.Range("H2:J6").Cells.ClearContents
.Range("8:8").Cells.ClearContents
.Range("ACC") = Fund
.Range("VIEW") = VIEWW
.Range("REQDATE") = RUN
.Range("F1I") = "A"
.Range("F1O") = "="
.Range("F1V") = "S"
.Range("A8:D8") = Array("D", "9", "A", "C")
.Activate
End With
'clear and run
Call Clear
Call Sec2
'copy over cus
With WsSec
rws = .Range("D11:D11").End(xlDown).row - 10
WsCus.Range("A1").Resize(rws, 1).Value = .Range("D11").Resize(rws).Value
End With
'get list for runs
With WsCus
.Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 2), Array(1, 1)), TrailingMinusNumbers:=True
.Range("B:B").Cells.ClearContents
.Range("A:A").RemoveDuplicates Columns:=1, Header:= _
xlNo
lr = .Cells(rows.count, "A").End(xlUp).row
.Range("B1:B" & lr).Formula = "=A1&""########"""
.Range("B1:B" & lr).Value = .Range("B1:B" & lr).Value
End With
'check if new tab needed
If WsCus.Range("A" & rows.count).End(xlUp).row > 18 Then
chk = MsgBox("A Cusip Tab needs to be created")
Exit Sub
End If
'set for runs and clear then run it
With WsSec
.Range("A8:L8") = Array("D", "9", "A", "C", "P", "T", "Q", "R", "T", "L", "6", "TC")
.Range("F2I") = "T"
.Range("F2O") = "!"
.Range("F2V") = ""
.Range("F3I") = "P"
.Range("F3O") = "<"
.Range("F3V") = "=Text(REQDATE, ""YYYYMMDD"")"
.Range("F4I") = "C"
.Range("F4O") = "="
End With
' Run loop to clear sheets
i = 0
Do Until WsCus.Range("FILTER").Offset(i, 0) = ""
FILTER = WsCus.Range("FILTER").Offset(i, 0)
SheetName = WsCus.Range("FILTER").Offset(i, -1).Value 'Assuming from your screenshot it's in the column left of the filter
Worksheets(SheetName).Cells.ClearContents
i = i + 1
Loop
' Run loop for range, clear, run, copy and paste into its respective sheet, apply formulas
i = 0
Do Until WsCus.Range("FILTER").Offset(i, 0) = ""
FILTER = WsCus.Range("FILTER").Offset(i, 0)
SheetName = WsCus.Range("FILTER").Offset(i, -1).Value 'Assuming from your screenshot it's in the column left of the filter
With WsSec
.Range("F4V") = FILTER
.Activate
End With
Call Clear
Call Sec2
'find the maximum row:
With WsSec
lastRow = .Cells(WsSec.rows.count, "A").End(xlUp).row
.Range("A10:L" & lastRow).Copy
End With
On Error Resume Next
If Not Worksheets(SheetName).Name = WsCus.Range("FILTER").Offset(i, -1).Value Then Worksheets.Add.Name = WsCus.Range("FILTER").Offset(i, -1).Value
On Error GoTo 0
With Worksheets(SheetName)
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Application.CutCopyMode = False 'Clear the copy-paste memory
lr1 = .Cells(rows.count, "A").End(xlUp).row
.Range("M1:Q1") = Array("4 digit", "Greater than 1yr", "Greater than 3yr", "Same Occurrence", "Same T & Occurrence")
.Application.Calculation = xlManual
'.Range("M2:M" & lr1).Formula = "=Round(K2, 4)"
'.Range("N2:N" & lr1).Formula = "=if(REQDATE-E2>365,""YES"",""NO"")"
'.Range("O2:O" & lr1).Formula = "=if(REQDATE-E2>(365*3),""YES"",""NO"")"
'.Range("P2:P" & lr1).Formula = "=COUNTIFS($D$2:$D$750000,D2,$M$2:$M$750000,M2)"
'.Range("Q2:Q" & lr1).Formula = "=COUNTIFS($D$2:$D$750000,D2,$E$2:$E$750000,E2,$M$2:$M$750000,M2)"
.Application.Calculation = xlAutomatic
'.Range("M2:Q" & lr1).Value = .Range("M2:Q" & lr1).Value
.Cells.EntireColumn.AutoFit
End With
i = i + 1
Loop
With WsSec
.Activate
End With
Call Clear
With WsExec
.Range("ENDD") = Time
.Range("DURATION").Formula = "=Text(ENDD - Start, ""hh:mm:ss"")"
.Range("DURATION").Value = .Range("DURATION").Value
.Protect
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Last edited:
