CountIF alternative for performance improvements

[ItalianPlatinum]

Little background I have an inventory management tool that consolidates inventory for products. There is no reporting for this tool. So before I run it I have no idea how long or how many lots could be eliminated. Therefore I need visibility before executing. My journey has been to find a way to replicate what it does via a macro (VBA) as reporting. The tool combines lots if they match criteria (cost, identifier). I.e. if two occurrences for the same identifier it sells 2 and buys on a combined 1. Trying to capture that.

I am able to extract data from the system but that data is so large it reaches the excel row limit so I have to move the data into sheets to break up the data, for example if identifier starts with G I move it to Sheet G, and so forth. My VBA currently loops through each identifier (extracting from the system). If starts with A extract from system, then transfer to sheet A, then run for B, transfer to sheet B. I then apply the countIF to find out how many lots fit the parameters and that is where my problem resides. My battle is how to handle the data. I created a summary sheet that lists all identifiers but then I had problems getting that to work. I have 3,700 identifiers, among those there are a total of 3 million lots. When I ran the VBA it took at day to run . Looking for some big time help here and willing to scrape it all if there is a better approach like leveraging the identifier approach on my summary sheet?

With Worksheets(SheetName)
        .Range("A1").Resize(lastRow - 10 + 1, 12).Value = WsSec.Range("A10:L" & lastRow).Value
lr1 = .Cells(rows.count, "A").End(xlUp).row
        .Range("M1:Q1") = Array("Rounded 2 digit", "Lot Greater than 1yr", "Lot Greater than 3yr", "For formula", "Same Occurrence")
        .Application.Calculation = xlAutomatic
        .Range("P2:P" & lr1).NumberFormat = "General"
        .Range("M2:M" & lr1).Formula = "=Round(K2, 2)"
        .Range("N2:N" & lr1).Formula = "=if(RUN-E2>365,""YES"",""NO"")"
        .Range("O2:O" & lr1).Formula = "=if(RUN-E2>(365*3),""YES"",""NO"")"
If TFLG = "N" Then
        .Range("P2:P" & lr1).Formula = "=D2&M2"
Else
        .Range("P2:P" & lr1).Formula = "=D2&E2&M2"
End If
        .Range("P2:P" & lr1).NumberFormat = "@"
        .Range("Q2").Formula2 = "=COUNTIF($P$2:$P$" & lr1 & ",$P$2:$P$" & lr1 & ")"
        .Range("M2:P" & lr1).Value = .Range("M2:P" & lr1).Value
End With

.Range("Q2").Formula2 = "=COUNTIF($P$2:$P$" & lr1 & ",$P$2:$P$" & lr1 & ")"

 

[bobsan42]

Post the whole procedure code, if possible.
And keep it all in memory (arrays or recordsets) , don't place the data on the sheets.
Where is the data stired? How do you get it?

 

[ItalianPlatinum]

Its pretty large is it okay if I post it still I don't want to inundate you? That is probably a good idea but that is where my VBA is limited may need advise of how to do that.

 

[bobsan42]

That is probably a good idea but that is where my VBA is limited may need advise of how to do that.

That's why it's good to post as much as possible code and details.

 

[ItalianPlatinum]

Awesome so few disclaimers: 1. I cannot modify the code for the sub Identifier that is the extract to pull from the system and 2. It must be run on WsSec. I can as you can see adjust how it runs to reduce the data and I already did that as best I can. See below.

Option Explicit
Sub RUN()
    Dim rws As Long
    Dim Department$, RUN As Date, RDate As Date, Section, Broker, FILTER, Start, ENDD, Duration, TFLG
    Dim ws As Worksheet, 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, lr2 As Long
    Dim chk
    Dim wsForSheet As Worksheet
    Dim loopRow As Long
    Dim lastRow As Long
    Dim sheetFilter As String
    Dim RNGFilter
    Dim i As Long
    Dim SheetName As String
    Dim t As Single
    
Application.ScreenUpdating = False
Application.EnableEvents = False

'set shortcut for worksheets
Set WsExec = Sheets("Execution")
Set WsSum = Sheets("Summary")
Set WsSec = Sheets("Identifier")
Set WsCus = Sheets("Identifier Check")
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
Department = WsExec.Range("Department")
RUN = WsExec.Range("Run")
Section = WsExec.Range("Section")
Start = WsExec.Range("START")
ENDD = WsExec.Range("ENDD")
Duration = WsExec.Range("DURATION")
Broker = WsExec.Range("Broker")
TFLG = WsExec.Range("TFLG")
RDate = WsExec.Range("RDATE")
FILTER = WsCus.Range("FILTER")

'clear and unprotect, set time for start day
With WsExec
    .Unprotect
    .Range("C6:C8").Cells.ClearContents
    .Range("Start") = Time
End With

'delete all sheets except ones listed
    For Each ws In ActiveWorkbook.Worksheets
        If (ws.Name <> "Execution") And (ws.Name <> "Identifier ") And (ws.Name <> "Summary") And (ws.Name <> "Identifier Check") Then
            ws.Cells.Delete
        End If
    Next ws

'set formatting
With WsCus
    .Cells.ClearContents
    .Range("A:A").NumberFormat = "@"
End With

'set formatting
With WsSum
    .Cells.ClearContents
    .Range("A:A").NumberFormat = "@"
End With

'clear and set system filters
With WsSec
    .Range("H2:J6").Cells.ClearContents
    .Range("8:8").Cells.ClearContents
    .Range("Client") = Department
    .Range("Section") = Section
    .Range("DATE") = RUN
    .Range("1ITEM") = "A"
    .Range("1OP") = "="
    .Range("1VALUE") = "S"
    .Range("A8:D8") = Array("D", "9", "A", "C")
    .Activate
    .Range("A10").CurrentRegion.Delete
End With

'run extract
Call Identifier

'copy over Identifiers to each tab
With WsSec
    rws = .Range("D11:D11").End(xlDown).Row - 10
    WsCus.Range("A1").Resize(rws, 1).Value = .Range("D11").Resize(rws).Value
    WsSum.Range("A2").Resize(rws, 1).Value = .Range("D11").Resize(rws).Value
End With

With WsSum
    .Range("A:A").RemoveDuplicates Columns:=1, Header:= _
        xlNo
    .Range("A1:D1") = Array("List of Identifiers", "Eligible for Consolidation", "to be Consolidated", "Total Consolidated")
    .Cells.EntireColumn.AutoFit
End With

'remove duplicates, generate for filters by leading letter followed by wild card for macro '#'
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 for Identifiers
If WsCus.Range("A" & Rows.Count).End(xlUp).Row > 18 Then
    chk = MsgBox("A Identifier sheet needs to be created")
    Exit Sub
End If
    
'set for lot runs and clear then run it
With WsSec
    .Range("A8:L8") = Array("D", "9", "A", "C", "P", "T", "Q", "R", "TD", "O", "1Q", "1T")
    .Range("1ITEM") = "T"
    .Range("2OP") = "!"
    .Range("2VALUE") = ""
    .Range("3ITEM") = "LP"
    .Range("3OP") = "<"
    .Range("3VALUE") = "=TEXT(RDATE,""YYYYMMDD"")"
    .Range("4ITEM") = "C"
    .Range("4OP") = "="
End With

' Run loop for range, clear, run, copy and paste into its respective sheet
  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

'apply filter to start loop and activate sheet
With WsSec
    .Range("4VALUE") = FILTER
    .Application.Calculation = xlManual
    .Activate
    .Range("A10").CurrentRegion.Delete
End With

    Call Identifier
    
'after execution copy from source and paste into relative sheet applying formulas
With WsSec
lastRow = .Cells(WsSec.Rows.Count, "A").End(xlUp).Row 'find the maximum row
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

t = Timer

With WsSec.Range("A10:L" & lastRow)
    Worksheets(SheetName).Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

Debug.Print "WsSec.Range... :  " & Format(Timer - t, "0.00") & " seconds"

t = Timer
With Worksheets(SheetName)
lr1 = .Cells(Rows.Count, "A").End(xlUp).Row
        .Range("M1:Q1") = Array("Rounded 2 digit Unit Cost", "Greater than 1yr", "Greater than 3yr", "For formula", "Same Occurrence")
        .Application.Calculation = xlAutomatic
        .Range("P2:P" & lr1).NumberFormat = "General"
        .Range("M2:M" & lr1).Formula = "=Round(K2, 2)"
        .Range("N2:N" & lr1).Formula = "=if(RUN-E2>365,""YES"",""NO"")"
        .Range("O2:O" & lr1).Formula = "=if(RUN-E2>(365*3),""YES"",""NO"")"
If TFLG = "N" Then
        .Range("P2:P" & lr1).Formula = "=D2&M2"
Else
        .Range("P2:P" & lr1).Formula = "=D2&E2&M2"
End If
        .Range("P2:P" & lr1).NumberFormat = "@"
        .Range("Q2").Formula2 = "=COUNTIF($P$2:$P$" & lr1 & ",$P$2:$P$" & lr1 & ")" 'need alternative takes too long
        '.Range("P2").Formula2 = "=COUNTIFS($D$2:$D$" & lr1 & ",$D$2:$D$" & lr1 & ",$M$2:$M$" & lr1 & ",$M$2:$M$" & lr1 & ")" 'combines matching and countif could help speed?
        .Range("M2:P" & lr1).Value = .Range("M2:P" & lr1).Value
        .Range("1:1").AutoFilter
        .Cells.EntireColumn.AutoFit
        .Activate
End With

Debug.Print "Worksheets(SheetName)... :  " & Format(Timer - t, "0.00") & " seconds"

ActiveWindow.ScrollRow = 1 'the row you want to scroll to
ActiveWindow.ScrollColumn = 1 'the column you want to scroll to
    
    i = i + 1
Loop

With WsSec
    .Activate
    .Range("A10").CurrentRegion.Delete
End With

t = Timer
With WsSum
lr2 = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("B2:B" & lr2).Formula2 = "=iferror(COUNTIFS(INDIRECT(LEFT(A2,1)&""!$D$2:$D$@@@""),A2,INDIRECT(LEFT(A2,1)&""!$Q$2#""),"">1""),0)"
    .Range("C2:C" & lr2).Formula = "=if(A2=0,0,COUNTA(UNIQUE(FILTER(INDIRECT(LEFT(A2,1)&""!$P$2:$P$@@@""),INDIRECT(LEFT(A2,1)&""!$D$2:$D$@@@"")=A2)))-COUNTIFS(INDIRECT(LEFT(A2,1)&""!$D$2:$D$@@@""),A2))" 'not working
    .Range("E1").Formula = "=SUM($C$2:$C$" & lr2 & ")" 'not working
End With

Debug.Print "Worksheets(WsSum)... :  " & Format(Timer - t, "0.00") & " seconds"

With WsExec
    .Range("ENDD") = Time
    .Range("DURATION").Formula = "=Text(ENDD - Start, ""hh:mm:ss"")"
    .Range("DURATION").Value = .Range("DURATION").Value
    .Protect
    .Activate
End With

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[bobsan42]

It is quite a task to figure out your whole project by a part of the code alone, so I decided not to try.
It actually relatively well structured, despite some remarks I may have. But I am a bit in the dark here, so maybe some of them may sound misplaced.
By the general looks of it you rely a lot on Excel's built-in functionality to complete whatever your task is. A that's probably OK, and in a lot of cases - easier. Why reinvent the wheel, anyway?
I cannot know, but I would guess, that a lot of effort and time is put into optimising Excel's functions while keeping them as versatile as possible. Some functions are maybe faster than others but usually at the cost of some limitations. So whatever we do on a higher level it is almost impossible to beat their productivity and performance. Only maybe under certain circumstances.
The only way to "beat" them and improve performance is not to look for alternative but to generally change the approach to the problem when we reach a "bottle-neck".
For example:

.Range("Q2").Formula2 = "=COUNTIF($P$2:$P$" & lr1 & ",$P$2:$P$" & lr1 & ")" 'need alternative takes too long

here you are looking for duplicates and counting them, I guess. The reason it takes too long is that you have a lot of values to check. The other part of the problem is that if you have duplicate values it counts its duplicates each time e.g. if you have 10 times the number 1 then 10 times you count how many 1s you have. Another example: if half of the values are equal to the other half then you can reduce the time in half if you count them only once.
If you only need to know the duplicates and their count it can be done much-much faster. Again, depending on the amount of duplicate values. While for Excel, it always takes the same time regardless of the amount of duplicates.

You also copy a lot of data around. Maybe it's not the biggest of problems but is it necessary.

Probably you need a general change of approach, but with too little information it is hard to give any ideas.

 

[ItalianPlatinum]

The problem is if I run the system extract once for ALL identifiers it crashes because I reach the excel row limit. So I have to jerry-rig a process where I run by the starting value of the identifier take it out of that sheet and place it in another sheet for use, clear the system extracting sheet and redoing for the next. I know I work with a lot of data.

Is there something I can explain or help you understand the project? From a layman's terms I extract from my system using Call Identifier via sheet WsSec. Then the data range A10-L is what i move to its own sheets. Then I have to find occurrences that match criteria. I can find out where my time suck is but I just don't know what my options are.

 

[bobsan42]

How do you extract the data? Where is it stored? What does Identifier do?

 

[ItalianPlatinum]

I extract the data from my core system by use of a SUB identifier. All the data is in the core system, The SUB identifier gives me the ability to see what's in my core system. The Excel wordbook is a data extracting tool from our web based system. I just added additional code, sheets for my project. Hope that helps answer your question.

 

[ItalianPlatinum]

I am not sure how to even do this but what if after I set the formulas then I have VBA that delete any row with Column Q equal to 1? Cause in reality if there is no pair or match that information is of no purpose to me. But I don't know if that helps me cause the formulas have to run in order to determine that but maybe it helps the next loop because less data in the workbook? Not sure trying to brainstorm cause as you can tell I am stuck.