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.
Imagine the following data, where we want to change priority
10 (which already exists) so it shoult be sorted right before
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: