# Sequence Generator from previous max sequence based on certain conditions

I'm new to VBA programming so the following code may look terrible which is why I want ways to understand how to better optimize it and other future codes.

Sub Sequence()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim unique_string1, unique_string2, unique_string3 As String

Dim arrj() As String
Dim arrk() As String
Dim arro() As String
Dim a, b, c As Long

'ARRAYj

jr = Sheets("Docs").Cells(Sheets("Docs").Rows.Count, 1).End(xlUp).Row
Set range1 = Sheets("Docs").Range("J2:J" & jr)
For Each cel In range1
If Not InStr(unique_string1, cel.Value) > 0 Then
unique_string1 = unique_string1 & cel.Value & ","
End If
Next
arrj = Split(unique_string1, ",")

'ARRAYk

kr = Sheets("Docs").Cells(Sheets("Docs").Rows.Count, 1).End(xlUp).Row
Set range2 = Sheets("Docs").Range("K2:K" & kr)
For Each cel In range2
If Not InStr(unique_string2, cel.Value) > 0 Then
unique_string2 = unique_string2 & cel.Value & ","
End If
Next
arrk = Split(unique_string2, ",")

'ARRAYo

pr = Sheets("Docs").Cells(Sheets("Docs").Rows.Count, 1).End(xlUp).Row
Set range3 = Sheets("Docs").Range("o2:o" & pr)
For Each cel In range3
If Not InStr(unique_string3, cel.Value) > 0 Then
unique_string3 = unique_string3 & cel.Value & ","
End If
Next
arro = Split(unique_string3, ",")

'ForLoop

For a = LBound(arrj) To UBound(arrj)
For b = LBound(arrk) To UBound(arrk)
For c = LBound(arro) To UBound(arro)
If Not (arrj(a) = "" Or arrk(b) = "" Or arro(c) = "") Then

Dim x, y, z As String
x = Trim(arrj(a))
y = Trim(arrk(b))
z = Trim(arro(c))

Dim lRow   As Long, i As Long
Dim ws     As Worksheet
Dim nextn  As Long
Set ws = ActiveSheet

With ws
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = 2 To lRow
If .Cells(i, 10).Value = x And .Cells(i, 11).Value = y And .Cells(i, 15).Value = z And .Cells(i, 23).Value = "" Then
nextn = 1 + Application.Evaluate("MAX(IF((J2:J20000=""" & x & """)*(K2:K20000=""" & y & """)*(O2:O20000=""" & z & """),INT(w2:20000)))")
End If
Next i
End With
End If
Next c
Next b
Next a
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub


So the code gets the distinct value from the columns and stores it in an array. Then those 3 arrays containing the distinct value combination is used to check for the max of the sequence and assigned a plus 1 to the max sequence if found. Else a 1.

How could I make this run faster considering there are a lot of rows and combinations to check?

P.s: If you have a code for getting distinct value from a column and store it into and array it would be great.

Mock-DATA

   J     K     O         W
1jobid  dep  job_no   Sequence
2 aaa   FJ     1         1      <existing data>
3 aaa   FJ     1         2
4 aaa   FJ     1         5
5 aaa   RJ     1         1
6 aaa   RJ     1         9
7 aaa   RJ     1         10     <existing data>
-----------------------------------------------------
8 aaa   RJ     1         11     <after the code is run, 11 is assigned>
9 aaa   FJ     1          6     <after the code is run, 6 is assigned >


columns J,K,O are strings and column W is number.

EDIT : As mentioned in the comments changed Range("J2:J20000" & jr) to Range("J2:J" & jr)

• Can you add some mock-data? The current code can only process 9 rows. Is the the working code or did you alter it for the post? – TinMan Dec 12 '19 at 8:16
• This is the working code. To be honest the current could takes a lot of time but when I break it I get some accurate value for the conditions that have executed successfully. I'll edit some mock-data. Btw what do you mean can only process 9 rows I got more than 9. – r00t Dec 12 '19 at 8:25
• The max number of rows in a worksheet is 1,048,576. If jr = 10 then Range("J2:J20000" & jr) would refer to row 2,000,010. – TinMan Dec 12 '19 at 8:29
• Is the ActiveSheet also Sheets("Docs")? – TinMan Dec 12 '19 at 8:48
• Yes the active sheet is Docs. And regarding the jr let me check – r00t Dec 12 '19 at 9:03

Dim unique_string1, unique_string2, unique_string3 As String


Variables declared without the As keyword are declared as a variant. In the line above unique_string3 is declared as a String, unique_string1 an unique_string2 are variants.

The original posted code use Range("J2:J20000" & jr). jr was being concatenated to the end of "J2:J20000". The post has been edited and corrected.

W is missing from the formula

INT(w2:20000))



Use .Cells(i, 23).Value = nextn instead. This will qualify the ranges to the worksheet instead of the ActiveSheet,

Sheets("Docs").Evaluate("MAX(IF((J2:J20000=""" & x & """)*(K2:K20000=""" & y & """)*(O2:O20000=""" & z & """),INT(w2:20000)))")


It is better to change the worksheets codenames for easy reference. VBA Codenames: Sheet (document) modules have a property called CodeName, which is how the object is know internally to VBA. Indeed, if this feature is used by the developer, VBA code can always refer to a sheet (worksheet or chart), even if the sheet is renamed from Excel by a user. For example:

• A worksheet is named 'Sales-2012'
• Sheet CodeName is 'Sales'
• User renames the worksheet to 'Sales-2013'

Use the Worksheet's Evaluate method instead of the Application's.

## Refactored Code

Here is a rough rewrite of the OP's code:

Option Explicit

Sub NewSequence()
Dim JobIds As Variant
JobIds = GetUniqueValues("J")

Dim Deps As Variant
Deps = GetUniqueValues("K")

Dim Job_Nos As Variant
Job_Nos = GetUniqueValues("O")

With wsDoc
Dim LastRow As Long
Rem Make sure that this refers to the longest used column
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

Const BaseFormula As String = "MAX(IF((J2:J@LastRow=""@jobid"")*(K2:K@LastRow=""@dep"")*(O2:O@LastRow=""@job_no""),INT(w2:w@LastRow)))"

Dim Formula As String
Dim Id As Long
Dim Department As Long
Dim JobNumber As Long
Dim i As Long

For Id = 0 To UBound(JobIds)
For Department = 0 To UBound(Deps)
For JobNumber = 0 To UBound(Job_Nos)
For i = 2 To LastRow
Formula = Replace(BaseFormula, "@LastRow", LastRow)
Formula = Replace(Formula, "@jobid", JobIds(Id))
Formula = Replace(Formula, "@dep", Deps(Department))
Formula = Replace(Formula, "@job_no", Job_Nos(JobNumber))
.Cells(i, 23) = 1 + .Evaluate(Formula)
Next
Next
Next
Next

End With
End Sub

Private Function GetUniqueValues(ColumnName As Variant) As Variant
Dim Target As Range
With wsDoc
Set Target = .Range(.Cells(2, ColumnName), .Cells(.Rows.Count, ColumnName).End(xlUp))
End With

Rem If there are no values then exit the function
Rem The calling method should test if the return value is an array using isArray()
If Target.Row = 1 Then Exit Function

Rem Range.Value will return an 1 based range of values it the Range contains multiple cells
Rem A Range that contains a single cell then it will return a single scalar value
If Target.Count = 1 Then
Rem Return the single value wrapped in a zero based array
GetUniqueValues = Array(Target.Value)
Exit Function
End If

Rem Typically a Scripting.Dictionary is used to return an unique lists
Dim list As Object
Set list = CreateObject("Scripting.Dictionary")

Rem assign an 1 based array of values from the Target range to an array
Dim Values As Variant
Values = Target.Value

Dim Item As Variant

Rem Use For Each controls to iterate over the Values array
For Each Item In Values
Item = Trim(Item)
If Not list.Exists(Item) And Len(Item) > 0 Then list.Add Key:=Item, Item:=Item
Next

Rem Return a zero based array from the Dictionary
GetUniqueValues = list.Keys
End Function


I changes the Doc tab codename to wsDocs for the code above. Thanks Peter T!

• I'm assuming that wsDoc is Dim wsDoc As Worksheet: Set wsDoc = ThisWorkbook.Sheets("Docs"). Also +1 for going old school with Rem comments ;) – PeterT Dec 12 '19 at 13:08
• @PeterT I must have removed the recommendation to change the codename to wsDoc by accident. I really like the look of the Rem. It's like having a row header for the comments. Thanks! – TinMan Dec 12 '19 at 17:38
• @TinMan you missed an important if condition If .Cells(i, 10).Value = x And .Cells(i, 11).Value = y And .Cells(i, 15).Value = z And .Cells(i, 23).Value = "" Then without this it started to change every row. I tested the performance using the original code with 19k entries it took about 40min. Testing it with this code. P.s: Testing first on a 4gb ram machine. – r00t Dec 15 '19 at 5:10
• update: the code you rewrote took about 30mins for 19k rows. Is it possible to tweak it to make it more efficient or is there any other solutions? – r00t Dec 15 '19 at 5:41
• @r00t I'm not sure what you mean. Columns 10, 11, 15, and 23 are party of the array formula. Their values should either be numeric or a #Value error. I think I need to clarify my question and provide better mock data. Actual usage will be 1k rows. – TinMan Dec 15 '19 at 6:06

The other feedback is quite good, so I just want to add a little tip about the section at the top:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual