Update priorities automatically

[JayCie]

I have a spreadsheet with all the projects we have ranked by 2 managers by priority. I need to renumber the priorities as projects become more urgent or are completed and am looking for a way to do this automatically as our list of projects grows.

The relevant columns are I, J and L.

As we update column L (Status) to 'Completed', I need columns I and J to ‘move’ a project up or down in priority. For example, if we mark Manger 2’s no 1 priority to completed, we want the current 1 to be deleted and 2 to become 1, 3 to become 2 and so on in Manager 2's column and, if there is a ranking in Manager 1's column it needs to be deleted and the projects in this column need to updated in the same manner..

Also, if we change a project’s priority I need to update the remaining priorities up or down as necessary. For example, if we change priority 5 to become priority 3, we need the existing 3 and 4 to become 4 & 5. Or, if we change priority 2 to priority 5, we need to change 3, 4 and the existing 5 to 2, 3 & 4.

Can anyone assist with some code that would accomplish this? Any assistance is appreciated.

 

[sijpie]

Assuming the columns you show are the correct columns: Right click on the sheet tab and select 'View code...'. Then Paste in the opened VBA window the following code:

Option Explicit
Dim mvPrio As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lR As Long, lTr As Long, lTc As Long
    Dim rPrio As Range
    
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    'check to see if columns I, J or L have been changed
    If (Not Intersect(Target, Range("I:J")) Is Nothing) Or _
       ((Not Intersect(Target, Columns("L")) Is Nothing) And LCase(Target) = "completed") Then
        lR = Cells(Rows.Count, "H").End(xlUp).Row
        Set rPrio = Range("H1:L" & lR)
        
        'load the range into an array for fast processing
        mvPrio = rPrio.Value
        lTr = Target.Row
        'get the column that needs to be worked on
        Select Case Target.Column
            Case 9  'column I
                lTc = 2
                MoveUpDown lTc, lTr, Target
        
            Case 10 'column J
                lTc = 3
                MoveUpDown lTc, lTr, Target
            
            Case 12 'column L
                If Len(mvPrio(lTr, 2)) Then
                    lTc = 2
                    mvPrio(lTr, 2) = 10000
                    MoveUpDown lTc, lTr, Target.Offset(0, -3)
                    mvPrio(lTr, 2) = vbNullString
                ElseIf Len(mvPrio(lTr, 3)) Then
                    lTc = 3
                    mvPrio(lTr, 3) = 10000
                    MoveUpDown lTc, lTr, Target.Offset(0, -2)
                    mvPrio(lTr, 3) = vbNullString
                Else
                    'error, set completed on empty row
                    Exit Sub
                End If
        End Select
        
        'write array back to sheet
        rPrio.Value = mvPrio
    End If
    
End Sub



Private Sub MoveUpDown(lCol As Long, lRow As Long, Target As Range)
    Dim lR As Long, lUB As Long
    Dim iPN As Integer, iCnt As Integer, iMax As Integer, iOld As Integer, iDbl As Integer
    Dim bDbl As Boolean
    
    iPN = mvPrio(lRow, lCol)    'new value
    lUB = UBound(mvPrio, 1)
    
    
    'find missing priority
    'get max prio nr and the double number
    
    iMax = Application.WorksheetFunction.Max(Target.EntireColumn)
    For iCnt = 1 To iMax
        For lR = 2 To lUB
            If mvPrio(lR, lCol) = iCnt Then
                Exit For
            End If
        Next lR
        If lR > lUB Then iOld = iCnt
        If iOld Then Exit For
    Next iCnt
    If iCnt >= iMax Then Exit Sub '= when new highest number added, _
                                   > should not happen, error trapping
    For lR = 2 To lUB
        If Not IsEmpty(mvPrio(lR, lCol)) And mvPrio(lR, lCol) = iPN And lR <> lRow Then
            iDbl = lR
            Exit For
        End If
    Next lR
    
    'now move the priorities
    Application.EnableEvents = False
    Select Case iPN < iOld
        Case True       'target was given lower priority
            For lR = 2 To UBound(mvPrio, 1)
                If mvPrio(lR, lCol) Then
                    If iPN = 0 Or (mvPrio(lR, lCol) > iPN And mvPrio(lR, lCol) < iOld) Or (mvPrio(lR, lCol) = iPN And lR <> lRow) Then
                        mvPrio(lR, lCol) = mvPrio(lR, lCol) + 1
                    End If
                End If
            Next lR
        Case False      'target was given higher priority
            For lR = 2 To UBound(mvPrio, 1)
                If mvPrio(lR, lCol) Then
                    If (mvPrio(lR, lCol) < iPN And mvPrio(lR, lCol) > iOld) Or (mvPrio(lR, lCol) = iPN And lR <> lRow) Then
                        mvPrio(lR, lCol) = mvPrio(lR, lCol) - 1
                    End If
                End If
            Next lR
    End Select
    Application.EnableEvents = True
End Sub

 

[JayCie]

Many thanks, Sijpie. You've obviously put a lot of effort into this. However, when I change the staus to 'Completed' either by typing or using the dropdown list, the priorities don't change. I made the change on priority number 4.

Before running the code:

After running the code:

I checked my macros under the Developer tab and this is not showing. Could it be because this is a 'Private Sub' and not just a 'Sub' code?

Again, thanks for your time and assisstance.
Jaycie

 

[sijpie]

It is correct that the macros don't appear under developer tag or pressing Alt-F8. Because you want the macro's to run automatically, these are held in the codemodule for the worksheet.

Is it possible to post a sanitised copy of the workbook in dropbox or similar? I think it has something to do with the sheet layout. I cant see columns or rows on your screenprints. If sensitive you can send me a private message with the location of the workbook.

 

[JayCie]

Yes, I can sanitise the data so nothing is identifiable and post a copy. It will take me a little while but I'll get it to you asap.

 

[JayCie]

Hi,
Link to the file:

Admin Support Request Register 200513.xlsm

Shared with Dropbox

www.dropbox.com

Please note I did not create this file but can make any necessary changes to the structure and set protection to prevent any of the many possible users making structure changes that may disrupt the macro.

I look forward to your response.
JayCie

 

[sijpie]

Thanks JayCie.

A question: how can an activity be assigned to both managers, and with a different priority (row 6&7 in your sheet)? Is that really the case or just an error in this example?

 

[sijpie]

Here is the new code. it will also do some error checking.

Option Explicit
Dim mvPrio As Variant

'----------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
' Checks in columns I, J and L which changes have _
  been made. If necessary calls MoveUpDown to _
  renumber priorities. Also checks for invalid _
  entries
'----------------------------------------------------
    Dim lR As Long, lTr As Long, lTc As Long
    Dim rPrio As Range
    
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    'check to see if columns I, J or L have been changed
    If (Not Intersect(Target, Range("I:J")) Is Nothing) Or _
       ((Not Intersect(Target, Columns("L")) Is Nothing) And LCase(Target) = "completed") Then
        lR = Cells(Rows.Count, "H").End(xlUp).Row
        Set rPrio = Range("H1:L" & lR)
        
        'load the range into an array for fast processing
        mvPrio = rPrio.Value
        lTr = Target.Row
        'get the column that needs to be worked on
        Select Case Target.Column
            Case 9  'column I
                lTc = 2
                If ErrorSet2Completed(lTc, lTr, CStr(Target.Offset(0, 3))) Then
                    Application.EnableEvents = False
                    Target = ""
                    Application.EnableEvents = True
                    Exit Sub
                End If
                MoveUpDown lTc, lTr, Target
        
            Case 10 'column J
                lTc = 3
                If ErrorSet2Completed(lTc, lTr, CStr(Target.Offset(0, 2))) Then
                    Application.EnableEvents = False
                    Target = ""
                    Application.EnableEvents = True
                    Exit Sub
                End If
                MoveUpDown lTc, lTr, Target
            
            Case 12 'column L
                If Len(mvPrio(lTr, 2)) Then
                    lTc = 2
                    mvPrio(lTr, 2) = 10000
                    MoveUpDown lTc, lTr, Target.Offset(0, -3)
                    mvPrio(lTr, 2) = vbNullString
                End If
                If Len(mvPrio(lTr, 3)) Then
                    lTc = 3
                    mvPrio(lTr, 3) = 10000
                    MoveUpDown lTc, lTr, Target.Offset(0, -2)
                    mvPrio(lTr, 3) = vbNullString
                End If
        End Select
        
        'write array back to sheet
        rPrio.Value = mvPrio
    End If
    
End Sub

'----------------------------------------------------
Private Function ErrorSet2Completed(lCol As Long, lRow As Long, sStatus As String) As Boolean
' Checks entry: if against completed task shows _
  error message and returns true. _
  if text entry, then returns true
'----------------------------------------------------
    Dim vEntry
    
    vEntry = mvPrio(lRow, lCol)
    If Len(vEntry) Then
        If IsNumeric(vEntry) Then
            If StrComp(sStatus, "completed", vbTextCompare) = 0 Then
                MsgBox "You cannot set a priority to a completed task", vbInformation, "Error setting priority"
                ErrorSet2Completed = True
            End If
        Else        'text entry, delete
            ErrorSet2Completed = True
        End If
    End If
End Function

'----------------------------------------------------
Private Sub MoveUpDown(lCol As Long, lRow As Long, Target As Range)
' Modifies the priority order
'----------------------------------------------------
    Dim lR As Long, lUB As Long
    Dim iPN As Integer, iCnt As Integer, iMax As Integer, iOld As Integer, _
        iDbl As Integer, iTot As Integer
    Dim bDbl As Boolean
    
    iPN = mvPrio(lRow, lCol)    'new value
    lUB = UBound(mvPrio, 1)
    
    
    
    'count number of priorities
    For lR = 3 To lUB
        If mvPrio(lR, lCol) Then iMax = iMax + 1
    Next lR
    
    'find missing priority
    For iCnt = 1 To iMax
        For lR = 3 To lUB
            If mvPrio(lR, lCol) = iCnt Then
                Exit For
            End If
        Next lR
        If lR > lUB Then iOld = iCnt
        If iOld Then Exit For
    Next iCnt
    
    'handle new number
    If iCnt >= iMax Then
        If iOld = 0 Then ' new highest number added
            Exit Sub
        Else 'user added prio number higher than next in sequence
            mvPrio(lRow, lCol) = iOld
            Exit Sub
        End If
    End If
    
    'find doubled number
    For lR = 3 To lUB
        If mvPrio(lR, lCol) = iPN And lR <> lRow Then
            iDbl = lR
            Exit For
        End If
    Next lR
    
    
    
    'now move the priorities
    Select Case iPN < iOld
        Case True       'target was given lower priority
            For lR = 3 To UBound(mvPrio, 1)
                If mvPrio(lR, lCol) Then
                    If iPN = 0 Or (mvPrio(lR, lCol) > iPN And mvPrio(lR, lCol) < iOld) Or (mvPrio(lR, lCol) = iPN And lR <> lRow) Then
                        mvPrio(lR, lCol) = mvPrio(lR, lCol) + 1
                    End If
                End If
            Next lR
        Case False      'target was given higher priority
            For lR = 3 To UBound(mvPrio, 1)
                If mvPrio(lR, lCol) Then
                    If (mvPrio(lR, lCol) < iPN And mvPrio(lR, lCol) > iOld) Or (mvPrio(lR, lCol) = iPN And lR <> lRow) Then
                        mvPrio(lR, lCol) = mvPrio(lR, lCol) - 1
                    End If
                End If
            Next lR
    End Select
End Sub

 

[JayCie]

This is correct. Our company investigates workplace accidents. Each of the managers has a team of inspectors and a number of investigations allocated to their teams. Although investigations can be carried out by inspectors from just one team, often inspectors from both teams are involved depending on their field of expertise. For example in a construction accident, we may have an asbestos expert from one team and an explosives expert from another team involved. If another investigation comes up involving only the asbestos expert, the new investigation may take a higher priority than the first in that team but does not necessarily change in priority for the team with the explosives expert.

I tested the new code and the results are:

If I change a status with a rating only in Mngr 2's column (J) to "Completed" it works exactly as it should;
If I change a status with a rating only in Mngr 1's column (I) or ratings in both columns I get a "Run-time error 13: Type mismatch" message;
If I enter a priority in Mngr 1's column (I) whether there is data in column J or not, I get the same error.

Really like the message "You cannot set a priority to a completed task". Thank you.

 

[JayCie]

Oops, I meant to add:

This is the line that generates the error:

at:

Private Sub MoveUpDown(lCol As Long, lRow As Long, Target As Range)

' Modifies the priority order

'----------------------------------------------------

Dim lR As Long, lUB As Long
Dim iPN As Integer, iCnt As Integer, iMax As Integer, iOld As Integer, _
iDbl As Integer, iTot As Integer
Dim bDbl As Boolean


iPN = mvPrio(lRow, lCol) 'new value
lUB = UBound(mvPrio, 1)


'count number of priorities
For lR = 3 To lUB
If mvPrio(lR, lCol) Then iMax = iMax + 1
Next lR


'find missing priority
For iCnt = 1 To iMax