Sequence Generator from previous max sequence based on certain conditions

Question

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
Application.DisplayAlerts = False
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
                Dim getAddress As String
                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
                            getAddress = .Cells(i, 23).Address
                            nextn = 1 + Application.Evaluate("MAX(IF((J2:J20000=""" & x & """)*(K2:K20000=""" & y & """)*(O2:O20000=""" & z & """),INT(w2:20000)))")
                            Range(getAddress).Value = nextn
                        End If
                    Next i
                End With                    
            End If
        Next c
    Next b
Next a
Application.ScreenUpdating = True
Application.DisplayAlerts = 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)

Answer 1

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


getAddress = .Cells(i, 23).Address
Range(getAddress).Value = nextn

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!

Answer 2

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
Application.DisplayAlerts = False

While this is not really problematic for one routine, it is a good general idea to encapsulate these calls in their own routine in a regular module so that you save yourself hassle and unnecessary code duplication if/when you work on a more involved project. Just use a set of names corresponding with each state of the application that make sense to you or one name that makes sense with feeding a boolean or (other parameter like an Enum in the case you need multiple states).