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...

 

[ItalianPlatinum]

So your saying where I have insert here?

Sub CreateFilterArrays()
    Dim WsSec As Worksheet, WsCus As Worksheet
    
    Set WsSec = Worksheets("Sec")                                        ' Change to your sheet name
    Set WsCus = Worksheets("Check")                                        ' 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
            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
'Insert here?
    Next collCodes
    
End Sub

 

[ItalianPlatinum]

Ok trying to do the below but not getting it how I would like it I want it to start at row 1. if I do the below Row 1 becomes blank. if I modify it to remove the +1 then the 2nd loop just overrides the E1. What may i be doing wrong?

    ' Loop through each collection of concatenated strings
    For Each collCodes In cusCollection
 nrCus = WsCus.Range("E" & rows.count).End(xlUp).row + 1
 WsCus.Range("E" & nrCus).Value = collCodes
    Next collCodes

 

[Alex Blakenburg]

On my mobile.

' Loop through each collection of concatenated strings
nrCus = WsCus.Range("E" & rows.count).End(xlUp).row
If nrCus = 1 and WsCus.Range("E" & nrCus).Value = "" then
nrCus = 0
Endif
For Each collCodes In cusCollection
nrCus = nrCus + 1
WsCus.Range("E" & nrCus).Value = collCodes
Next collCodes

 

[ItalianPlatinum]

Wonderful this has made my total run time from 14 minutes to 8 minutes. Big improvement.