Prioritization of projects VBA

Question

I have a list of 30 projects displayed in lines, I need to give the user the possibility to change the priority of projects on VBA form.

The form is fine, the user can look for the project he wants (by clicking on look for project), the Old priority is filled automatically and he is asked to type the new priority:

By Clicking on OK, the new priority for that project should substitute the old priority for that project and it should re order everything on priority column.

The code I have almost works, but it leaves a whole, in the example below, I change the project with priority 3 to priority 10, it changed the whole column, but it disappeared with project priority 3:

This is the code I have:

(It is really messy and I can´t figure out a way to make it work)

' After clicking on look for project , where cell focus in on the project he wants to change priority

Private Sub CommandButton1_Click()
Dim old_priority As String
Dim CELL As Range


ActiveCell.Offset(0, -1).Select
ActiveCell.Value = new_priority.Text

For Each CELL In Range("b8:b36")

   If CELL.Value >= new_priority.Text + 1 Then
   CELL.Value = CELL.Value + 1
   Else
   End If


   If CELL.Value = new_priority.Text Then
   CELL.Value = CELL.Value + 1
   Else
   End If

Next CELL

   ThisWorkbook.Sheets("sheet5").Range("c27").Value = new_priority.Text


    Cells.Find(What:=ThisWorkbook.Sheets("sheet5").Range("b27").Value, After:=ActiveCell, LookIn:=xlFormulas, _
       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False, SearchFormat:=False).Activate
    Prioridade.Text = ActiveCell.Offset(0, -1).Value
    ActiveCell.Offset(0, -1).Select
    ActiveCell.Value = new_priority.Text



        Unload Me

End sub

I am sure there is an easier way to loop throught the cells and re order the list.

Actually you can just sort by column priority and rewrite the numbers `1…n`. But it is unclear what happens if the user enters a priority that already exists in the list. Can you clarify? — Pᴇʜ, Jun 12 '19 at 13:35
If the user enters a priority that already exists, the priority that are lower don´t change, the priority that are higher or equal than the new priority should move (add 1?). The ideal end result is a list of numbers ( 1 to 30), even if it is not in order (I´ll rearrange later), but there cannot be repeated numbers or numbers missing. — ROCA, Jun 12 '19 at 13:43
In that case it would be more complicated. You need to check if the new priority (eg `10`) already exists. If it exists subtract a very small number like `0.01` so you write `9.99` this way it will be sorted below the existing `10`. Then use the [Range.Sort method](https://learn.microsoft.com/en-us/office/vba/api/excel.range.sort) to sort your data by priority. After that loop through priority column and write ascending numbers starting with `1`. So you will end up with ascending numbers without skips or doubles. — Pᴇʜ, Jun 12 '19 at 13:49
Read [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). You should steer clear from `Activate` as well — Tim Stack, Jun 12 '19 at 13:52
@Pᴇʜ has a good idea here, however, there are 2 lines that alwasy matches the new priority, the one that the user typed and the old one that was already there... anyway... — ROCA, Jun 12 '19 at 14:09

score 2 · Accepted Answer · answered Jun 12 '19 at 14:13

Imagine the following data, where we want to change priority 3 into 10 (which already exists) so it shoult be sorted right before 10.

Then we use the following code:

Option Explicit

Public Sub Test()
    ReOrder OldPriority:=3, NewPriority:=10
End Sub

Public Sub ReOrder(OldPriority As Long, NewPriority As Long)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Tabelle9")

    Dim MatchRow As Double
    On Error Resume Next
        MatchRow = Application.WorksheetFunction.Match(OldPriority, ws.Columns("A"), 0)
    On Error GoTo 0

    If MatchRow = 0 Then
        MsgBox "The old priority number did not exist.", vbCritical
        Exit Sub
    End If

    'write new priorty
    ws.Cells(MatchRow, "A").Value = NewPriority - 0.001 'subtract a small number so it will always sort before existing priorities

    'sort by priortiy
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=ws.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange ws.Range("A:B") 'your data range
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    'rewrite priority numbers ascending
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim iRow As Long
    For iRow = 2 To LastRow
        ws.Cells(iRow, "A") = iRow - 1
    Next iRow
End Sub

After the new priorirty was written and the data was sorted by priority it looks like this:

So we just need to rewrite the numbers and we end up here:

I did not think about re ordering ascending and then re index the numbers, great @Peh , thanks. — ROCA, Jun 12 '19 at 16:17

Prioritization of projects VBA

1 Answers1