Range used for loops based off criteria

[ItalianPlatinum]

I need some help creating a line of code that will help me optimize my current VBA. I am running into performance issues because of running my loop off of each individual range but I can improve it by combining ranges. I have to apply each due to the size of my data. I have since improved it but need help to further optimize. Below is my dilemma and what I would need.

I can extract from my core system by identifier to limit the data by doing so I still reach my excel row limit. So I loop through using a named range (column B below), to avoid that and transfer just the data I need over, clearing and starting over. I can combine those ranges using variables and looking for a way to do that dynamically. A way to run as many combined without reaching my excel row limit. In my prep work I can get how many rows each range would generate (column C below). In this example I could run the first 12. Then the last 2. So I could cut my loop from 14 to 2. The NEW ranges would need to combine the records separated by a colon like this:

Loop 1 - G########:H########:M########:N########:0########:1########:2########:3########:4########:5########:6########:7########
Loop 2 - 8########:9########

WsSec where I extract from system
WsCus (sheet)

Book1
	A	B	C	D
1	G	G########	3696	1374956
2	H	H########	135
3	M	M########	380
4	N	N########	370
5	0	0########	259320
6	1	1########	186070
7	2	2########	21008
8	3	3########	16295
9	4	4########	21225
10	5	5########	210450
11	6	6########	18517
12	7	7########	241000
13	8	8########	256900
14	9	9########	139590
Sheet1

Cell Formulas
Range	Formula
D1	D1	=SUM(C1:C14)

'check if row limit will be exceeded if so then proceed with running per starting value of indentifier transfering to sheet
If TOTAL > 1048576 Then

'set for lot runs and clear then run it
With WsSec
    .Range("ITEM") = "I"
    .Range("OP") = "="
End With

t = Timer
' 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)

'apply filter to start loop and activate sheet
With WsSec
    .Range("VALUE") = FILTER
    .Application.Calculation = xlManual
    .Range("A10").CurrentRegion.Delete
    .Activate
End With
Debug.Print "Worksheets(WsSec)Delete... :" & Format(Timer - t, "0.00") & " seconds"

t = Timer
    Call Sec2
Debug.Print "Worksheets(WsSec)... :" & Format(Timer - t, "0.00") & " seconds"

'Other code to transfer data, apply formulas, and etc...

 

[iggydarsa]

Not sure if this helps and not sure if you know but you can get the last row that being used and you can loop through only those rows instead of breaking your loops into smaller chunks

Sub MyCode()
    lr = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 1 To lr
        'Your code
    Next i
End Sub

 

[ItalianPlatinum]

Thanks Iggy yea I am aware. it seems your approach is just an alternative to my already functioning loop but not a solution for combining them to just be able to reach my excel row limit. Each loop takes 40sec to run. So the purpose if I can limit the loops I can easily cut 5min

 

[ItalianPlatinum]

I will take any and all suggestions. This loop per each is what creates the most time. So if I can combine like the above even in blocks so I still don't reach the excel row limit that would help on timing

 

[Alex Blakenburg]

You are not showing enough of the code or the data to give a full answer.
I think this might be the sort of thing you are looking to do.

Sub CreateFilterArrays()
    Dim WsSec As Worksheet, WsCus As Worksheet
    
    Set WsSec = Worksheets("Sheet1")                                        ' Change to your sheet name
    Set WsCus = Worksheets("Sheet2")                                        ' Change to your sheet name
    
    Dim cusRng As Range, cusLastRow As Long, cusArr As Variant
    Dim cusCollection As Collection, sCodes As String, lCodeSum As Long
    Dim i As Long
    
    With WsCus
        cusLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
        Set cusRng = .Range(.Cells(1, "A"), .Cells(cusLastRow + 1, "C"))    ' Add 1 row to simplify loop
        cusArr = cusRng.Value
    End With
    
    ' Create an item in a collection for each concatenated string which makes
    ' up a group totaling < Max allowed ie 1048576
    Set cusCollection = New Collection
    For i = 1 To UBound(cusArr) - 1
        sCodes = sCodes & ":" & cusArr(i, 2)
        lCodeSum = lCodeSum + cusArr(i, 3)

        If lCodeSum + cusArr(i + 1, 3) > 1048576 Or (i = UBound(cusArr) - 1) Then
            sCodes = Right(sCodes, Len(sCodes) - 1)
            cusCollection.Add sCodes
            Debug.Print lCodeSum, sCodes                                    ' Remove after testing - shows cumulative values
            sCodes = ""
            lCodeSum = 0
        End If
    Next i
    
    Dim collCodes As Variant
    Dim splitCode As Variant
    
    ' Loop through each collection of concatenated strings
    For Each collCodes In cusCollection
        Debug.Print collCodes                                               ' Remove after testing - Show each group to be split
        
        ' Split the concatenated strings back into individual items
        splitCode = Split(collCodes, ":")
        For i = 0 To UBound(splitCode)
            Debug.Print splitCode(i)                                        ' Remove after testing - Show each item in group
        Next i
    Next collCodes
    
End Sub

 

[ItalianPlatinum]

I will give that a try tomorrow morning (seeing its late here now). Alex you are always very helpful - I appreciate it. I can provide more code tomorrow if needed I figured on this maybe less was more?

 

[ItalianPlatinum]

Ok Cool - so need a bit of understanding on this. The top section is what I am looking for (EXACTLY) but the bottom section is just leftover data? 2nd question how do I play that back to my WsCus sheet on a named range like FILTER2? I will show you what I mean. This way the loop can be set to Filter2 and Filter can remain for conditions less than the excel limit ill paste that code so you get what I am saying

758009 A########:G########:H########:L########:M########:N########:V########:Y########:0########:1########
871429 2########:3########:4########
809083 5########:6########:7########
599085 8########:9########
A########:G########:H########:L########:M########:N########:V########:Y########:0########:1########
A########
G########
H########
L########
M########
N########
V########
Y########
0########
1########
2########:3########:4########
2########
3########
4########
5########:6########:7########
5########
6########
7########
8########:9########
8########
9########

'check if row limit will be exceeded if so then proceed with running per starting value transferring to sheet
If TOTAL > 1048576 Then

FILTER2 = .Range("FILTER2")
Call CreateFilterArrays

'set for lot runs and clear then run it
With WsSec
    .Range("5ITEM") = "C"
    .Range("F5OP") = "="
End With

t = Timer
' Run loop for range, clear, run, copy and paste into sheet
  i = 0
  Do Until WsCus.Range("FILTER2").Offset(i, 0) = ""
    FILTER2 = WsCus.Range("FILTER2").Offset(i, 0)

'apply filter to start loop and activate sheet
With WsSec
    .Range("5VALUE") = FILTER2
    .Application.Calculation = xlManual
    .Range("A10").CurrentRegion.Delete
    .Activate
End With
Debug.Print "Worksheets(WsSec)Delete... :" & Format(Timer - t, "0.00") & " seconds"

t = Timer
    Call Sec2 'runs procedure on WsSec only able to be run on this sheet (extract data from core system)

'rest of code run procedure, clear, transfer to sheet apply count formulas assess data, etc. then loop back through

 

[Alex Blakenburg]

I have no idea what you are trying to do. I was just demonstrating how you could come up with the concatenated string and how you loop through the set of them (collection) and break them up again if required.
What does your data source look like and what does the intended result look like ?

 

[ItalianPlatinum]

I am essentially just trying to limit my loops and I can do that by combining separated by a :. So in the example above instead of looping through 1-18. I can combine records like you did to reduce the amount of loops so here I am going from 18 to 4. If I can have that written to WsCus E1 that would be ideal and I think would suffice (barring need to test). The caveat is the concatenates must not allow me to breach the excel row limit. Each individual loop takes 45 secs to run (45secs x 18 gets me around 14min). But with reduced loops when I manually run to test each of those combined loops is 1.15min x 4 at 4.5min so as you can see I can reduce my time efficiency a lot. I hope this clarifies and didn't confuse more. I know its a unique request and hard to explain well enough so you understand it fully.

758009 A########:G########:H########:L########:M########:N########:V########:Y########:0########:1########
871429 2########:3########:4########
809083 5########:6########:7########
599085 8########:9########

In cell E1 A########:G########:H########:L########:M########:N########:V########:Y########:0########:1########
In cell E2 2########:3########:4########
In cell E3 5########:6########:7########
In cell E4 8########:9########

 

[Alex Blakenburg]

Remove this code (and the debug lines) from what I gave you and you have that

        ' Split the concatenated strings back into individual items
        splitCode = Split(collCodes, ":")
        For i = 0 To UBound(splitCode)
            Debug.Print splitCode(i)                                        ' Remove after testing - Show each item in group

You just need to output collCodes to the cell you want it to go to.