3
\$\begingroup\$

I created this simple macro that works fine for its purpose: allow the user to create a list of updates that need to be made based on groups in a target table (to basically do mass updates).

However, I am very concerned about the performance of this macro, it would take less time to do it manually if the list of updates becomes significantly long. I started optimizing the code using arrays but that seems not be enough.

What I am going to look into next is the use of dictionaries, is anyone aware of the most optimal way to achieve this?

Sub UpdateManualUpdates()
    Application.ScreenUpdating = False
    Dim lookUpSheet As Worksheet, updateSheet As Worksheet
    Dim valueToSearch As String
    Dim i As Long, t As Long

    Set lookUpSheet = Worksheets("Manual price changes")
    Set updateSheet = Worksheets("Price Build-up")

    Dim lookUpSheetArray As Variant
    Dim updateSheetArray As Variant

    lastRowLookup = lookUpSheet.Cells(Rows.Count, "F").End(xlUp).Row
    lastRowUpdate = updateSheet.Cells(Rows.Count, "B").End(xlUp).Row

    lookUpSheetArray = lookUpSheet.Range("A1:F" & lastRowLookup).Value
    updateSheetArray = updateSheet.Range("A1:AW" & lastRowUpdate).Value

    For i = 6 To lastRowLookup 'i = 2 to last to omit the first row as that row is for headers

        valueType = lookUpSheetArray(i, 5) 'lookUpSheet.Cells(i, 5) 'Type of update - Both, Planning group or GC
        valueGroup = lookUpSheetArray(i, 3) 'Family group
        valueGC = lookUpSheetArray(i, 4) 'GC
        ValueChange = lookUpSheetArray(i, 6) 'What is the % change
        'above get the values from the four column into variables

        For t = 6 To lastRowUpdate
            'AW is column 49 target column to update
            'M is target column for group, 13
            'C is target column for GC, 3
            If valueType = "Both" Then
                If updateSheetArray(t, 13) = valueGroup And updateSheetArray(t, 3) = valueGC Then
                    updateSheet.Cells(t, 49) = ValueChange
                End If
            End If
            If valueType = "Planning group" Then
                If updateSheetArray(t, 13) = valueGroup Then
                    updateSheet.Cells(t, 49) = ValueChange
                End If
            End If
            If valueType = "GC" Then
                If updateSheetArray(t, 3) = valueGC Then
                    updateSheet.Cells(t, 49) = ValueChange
                End If
            End If
        Next t
    Next i
    Application.ScreenUpdating = True
End Sub
\$\endgroup\$
0
\$\begingroup\$

It looks like you'll have to set up three dictionaries that reference the same data. In your case, the dictionaries are based on your TARGET data that should change: updateSheetArray. You need three dictionaries because you want to access the data three different ways. The trick is in choosing a unique value from the data to be used as the key into the data. The first two values are simple, single column values: PlanningGroup and GC.

Since one of your choices is "Both", you have to create a key from the data that combines both of those fields into a single value. This can be done on the worksheet itself in the form of a visible or hidden column (and thus also pulled into a memory array), or you can combine the fields in your VBA code. My preferred method for this is to combine the two (or more) fields into a single string in the code, though each situation is different. You can do a simple concatenate or concatenate with a delimiter, it does't matter.

Before we get to the dictionary part of the answer, I will suggest a few items in the code review part of this answer.

  1. Always use Option Explicit. You might be doing this, but it's good to make sure it's visible in your questions (or answers) so it doesn't come up like this.
  2. Declare your variables as close as possible to the first use of the variable. It saves lots of back and forth searching for declarations, plus your code is now a little grouped into "logic blocks".
  3. Define constants for "magic numbers". These are typically a straight numerical value you've hard-coded into your routines. Any other developer that comes along will have to scratch their head to figure out why you're starting a loop from index 6. You also might need to use the same value in multiple places, so creating a Const once isolates the definition and then you only have to change it once.

The constants I've defined for my example solution are:

Private Const LOOKUP_TYPE_COL As Long = 5
Private Const LOOKUP_GROUP_COL As Long = 3
Private Const LOOKUP_GC_COL As Long = 4
Private Const LOOKUP_CHANGE_COL As Long = 6
Private Const UPDATE_GROUP_COL As Long = 13
Private Const UPDATE_GC_COL As Long = 3
Private Const UPDATE_CHANGE_COL As Long = 49
Private Const START_OF_LOOKUP_DATA As Long = 2
Private Const START_OF_UPDATE_DATA As Long = 6

I've made these constants Private at the global module level, but they easily could be restricted in scope to the single Sub in the code. (The example Sub below is a bit long and I could have separated it into smaller functions, I'll leave that as an exercise for the reader :) ).

One problem I noticed in your code is when you're calculating the last row. Your statement is good but you've missed a worksheet reference when using Rows.Count. Since the Rows is not qualified with a worksheet reference, it is counting the rows on the currently active sheet. My habit is to wrap the statement in a With block, just to make sure I have to correct reference:

Dim lookUpSheet As Worksheet
Dim lastRowLookup As Long
Dim lookUpSheetRange As Range
Dim lookUpSheetArray As Variant
Set lookUpSheet = Worksheets("Manual price changes")
With lookUpSheet
    lastRowLookup = .Cells(.Rows.Count, "F").End(xlUp).Row
    Set lookUpSheetRange = .Range("A1").Resize(lastRowLookup, 6)
    lookUpSheetArray = lookUpSheetRange.value
End With

Dim updateSheet As Worksheet
Dim lastRowUpdate As Long
Dim updateSheetRange As Range
Dim updateSheetArray As Variant
Set updateSheet = Worksheets("Price Build-up")
With updateSheet
    lastRowUpdate = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set updateSheetRange = .Range("A1").Resize(lastRowUpdate, 49)
    updateSheetArray = updateSheetRange.value
End With

You are copying data from the worksheet Range into a memory-based array, and that will give you a much faster execution. The bonus is that you're not interacting with the screen, so Application.ScreenUpdating = False is not necessary. (You'll see another change to support this below)

Now comes the Dictionary build up. We're working with your target data, which is the sheet that needs to be updated. You want to be able to find any row in your data with a single reference. I'm assuming the data on your updateSheet could be hundreds or thousands of lines long. Notice in the loop below that I'm creating three dictionaries, including using a combination key to pick up the option to reference entries for "both".

Also, I figured that there could be more than one row in the data that may match the update criteria. So the dictionary keeps track by building a (string) list of row numbers to use later.

Dim groupKeys As Dictionary
Dim gcKeys As Dictionary
Dim bothKeys As Dictionary
Set groupKeys = New Dictionary
Set gcKeys = New Dictionary
Set bothKeys = New Dictionary

Dim updateGroup As String
Dim updateGC As String
Dim bothKey As String
Dim existingList As String
Dim i As Long
For i = START_OF_UPDATE_DATA To UBound(updateSheetArray, 1)
    updateGroup = updateSheetArray(i, UPDATE_GROUP_COL)
    updateGC = updateSheetArray(i, UPDATE_GC_COL)

    If Not groupKeys.Exists(updateGroup) Then
        groupKeys.Add updateGroup, CStr(i)
    Else
        existingList = groupKeys(updateGroup)
        groupKeys(updateGroup) = existingList & "," & CStr(i)
    End If

    If Not gcKeys.Exists(updateGC) Then
        gcKeys.Add updateGC, CStr(i)
    Else
        existingList = gcKeys(updateGC)
        gcKeys(updateGC) = existingList & "," & CStr(i)
    End If

    bothKey = updateGroup & updateGC
    If Not bothKeys.Exists(bothKey) Then
        bothKeys.Add bothKey, CStr(i)
    Else
        existingList = bothKeys(bothKey)
        bothKeys(bothKey) = existingList & "," & CStr(i)
    End If
Next i

Now that we have the dictionaries complete, we only need a single pass through the lookUpSheet data. We'll get the list of rows from the selected dictionary, then update only those rows in the memory-based array NOT directly on the worksheet. So this inside loop is restricted to ONLY the rows needing updated values. This is where you get your other burst of speed.

Dim valueGroup As String
Dim valueGC As String
Dim valueType As String
Dim valueChange As Double
Dim updateRows As Variant
For i = START_OF_LOOKUP_DATA To UBound(lookUpSheetArray, 1)
    valueType = lookUpSheetArray(i, LOOKUP_TYPE_COL)
    valueGroup = lookUpSheetArray(i, LOOKUP_GROUP_COL)
    valueGC = lookUpSheetArray(i, LOOKUP_GC_COL)
    bothKey = valueGroup & valueGC

    valueChange = lookUpSheetArray(i, LOOKUP_CHANGE_COL)

    updateRows = -1      'reset to a non-array value
    Select Case valueType
        Case "Planning group"
            If groupKeys.Exists(valueGroup) Then
                updateRows = Split(groupKeys(valueGroup), ",")
            End If

        Case "GC"
            If gcKeys.Exists(valueGC) Then
                updateRows = Split(gcKeys(valueGC), ",")
            End If

        Case "Both"
            If bothKeys.Exists(bothKey) Then
                updateRows = Split(bothKeys(bothKey), ",")
            End If

    End Select

    '--- update the values if we found the rows to update
    If IsArray(updateRows) Then
        Dim j As Long
        For j = LBound(updateRows, 1) To UBound(updateRows, 1)
            updateSheetArray(CLng(updateRows(j)), UPDATE_CHANGE_COL) = valueChange
        Next j
    End If
Next i

The final step is to copy the modified memory array back to the worksheet (which is why I created the updateSheetRange variable earlier).

updateSheetRange.value = updateSheetArray

Here is the whole solution in a single module:

Option Explicit

Private Const LOOKUP_TYPE_COL As Long = 5
Private Const LOOKUP_GROUP_COL As Long = 3
Private Const LOOKUP_GC_COL As Long = 4
Private Const LOOKUP_CHANGE_COL As Long = 6
Private Const UPDATE_GROUP_COL As Long = 13
Private Const UPDATE_GC_COL As Long = 3
Private Const UPDATE_CHANGE_COL As Long = 49
Private Const START_OF_LOOKUP_DATA As Long = 2
Private Const START_OF_UPDATE_DATA As Long = 6

Sub UpdateManualUpdates()
    Dim lookUpSheet As Worksheet
    Dim lastRowLookup As Long
    Dim lookUpSheetRange As Range
    Dim lookUpSheetArray As Variant
    Set lookUpSheet = Worksheets("Manual price changes")
    With lookUpSheet
        lastRowLookup = .Cells(.Rows.Count, "F").End(xlUp).Row
        Set lookUpSheetRange = .Range("A1").Resize(lastRowLookup, 6)
        lookUpSheetArray = lookUpSheetRange.value
    End With

    Dim updateSheet As Worksheet
    Dim lastRowUpdate As Long
    Dim updateSheetRange As Range
    Dim updateSheetArray As Variant
    Set updateSheet = Worksheets("Price Build-up")
    With updateSheet
        lastRowUpdate = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set updateSheetRange = .Range("A1").Resize(lastRowUpdate, 49)
        updateSheetArray = updateSheetRange.value
    End With

    '--- build up the dictionaries for the UPDATE array where the keys
    '    are single or multiple fields and the entry is CSV list of
    '    row numbers that match the given key
    Dim groupKeys As Dictionary
    Dim gcKeys As Dictionary
    Dim bothKeys As Dictionary
    Set groupKeys = New Dictionary
    Set gcKeys = New Dictionary
    Set bothKeys = New Dictionary

    Dim updateGroup As String
    Dim updateGC As String
    Dim bothKey As String
    Dim existingList As String
    Dim i As Long
    For i = START_OF_UPDATE_DATA To UBound(updateSheetArray, 1)
        updateGroup = updateSheetArray(i, UPDATE_GROUP_COL)
        updateGC = updateSheetArray(i, UPDATE_GC_COL)

        If Not groupKeys.Exists(updateGroup) Then
            groupKeys.Add updateGroup, CStr(i)
        Else
            existingList = groupKeys(updateGroup)
            groupKeys(updateGroup) = existingList & "," & CStr(i)
        End If

        If Not gcKeys.Exists(updateGC) Then
            gcKeys.Add updateGC, CStr(i)
        Else
            existingList = gcKeys(updateGC)
            gcKeys(updateGC) = existingList & "," & CStr(i)
        End If

        bothKey = updateGroup & updateGC
        If Not bothKeys.Exists(bothKey) Then
            bothKeys.Add bothKey, CStr(i)
        Else
            existingList = bothKeys(bothKey)
            bothKeys(bothKey) = existingList & "," & CStr(i)
        End If
    Next i

    '--- now compare each row of the lookup data to find it in the update
    '    data and make the appropriate change to the memory array
    Dim valueGroup As String
    Dim valueGC As String
    Dim valueType As String
    Dim valueChange As Double
    Dim updateRows As Variant
    For i = START_OF_LOOKUP_DATA To UBound(lookUpSheetArray, 1)
        valueType = lookUpSheetArray(i, LOOKUP_TYPE_COL)
        valueGroup = lookUpSheetArray(i, LOOKUP_GROUP_COL)
        valueGC = lookUpSheetArray(i, LOOKUP_GC_COL)
        bothKey = valueGroup & valueGC

        valueChange = lookUpSheetArray(i, LOOKUP_CHANGE_COL)

        updateRows = -1      'reset to a non-array value
        Select Case valueType
            Case "Planning group"
                If groupKeys.Exists(valueGroup) Then
                    updateRows = Split(groupKeys(valueGroup), ",")
                End If

            Case "GC"
                If gcKeys.Exists(valueGC) Then
                    updateRows = Split(gcKeys(valueGC), ",")
                End If

            Case "Both"
                If bothKeys.Exists(bothKey) Then
                    updateRows = Split(bothKeys(bothKey), ",")
                End If

        End Select

        '--- update the values if we found the rows to update
        If IsArray(updateRows) Then
            Dim j As Long
            For j = LBound(updateRows, 1) To UBound(updateRows, 1)
                updateSheetArray(CLng(updateRows(j)), UPDATE_CHANGE_COL) = valueChange
            Next j
        End If
    Next i

    '--- all of the requested updates are complete, copy the array back to the worksheet
    updateSheetRange.value = updateSheetArray
End Sub
\$\endgroup\$
  • \$\begingroup\$ Hi, thanks this looks and functions very fast. However when the macro finishes to run it deletes all formulas and tables from the updated sheet. Do you know the reason? \$\endgroup\$ – PBPB Jul 3 at 9:44

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.