4
\$\begingroup\$

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)

\$\endgroup\$
  • \$\begingroup\$ 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? \$\endgroup\$ – TinMan Dec 12 '19 at 8:16
  • \$\begingroup\$ 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. \$\endgroup\$ – r00t Dec 12 '19 at 8:25
  • \$\begingroup\$ 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. \$\endgroup\$ – TinMan Dec 12 '19 at 8:29
  • \$\begingroup\$ Is the ActiveSheet also Sheets("Docs")? \$\endgroup\$ – TinMan Dec 12 '19 at 8:48
  • \$\begingroup\$ Yes the active sheet is Docs. And regarding the jr let me check \$\endgroup\$ – r00t Dec 12 '19 at 9:03
4
\$\begingroup\$
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!

|improve this answer|||||
\$\endgroup\$
  • 2
    \$\begingroup\$ I'm assuming that wsDoc is Dim wsDoc As Worksheet: Set wsDoc = ThisWorkbook.Sheets("Docs"). Also +1 for going old school with Rem comments ;) \$\endgroup\$ – PeterT Dec 12 '19 at 13:08
  • \$\begingroup\$ @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! \$\endgroup\$ – TinMan Dec 12 '19 at 17:38
  • \$\begingroup\$ @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. \$\endgroup\$ – r00t Dec 15 '19 at 5:10
  • \$\begingroup\$ 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? \$\endgroup\$ – r00t Dec 15 '19 at 5:41
  • \$\begingroup\$ @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. \$\endgroup\$ – TinMan Dec 15 '19 at 6:06
2
\$\begingroup\$

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

|improve this answer|||||
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.