Live On-the-Fly Force Ranking

[rjbinney]

Dear Mr. Excel:

I need to create a table where people can submit "Top Ten" lists. Column A can be freeform.

I have it so Column B autopopulates 1-n based on whether or not A is blank.

Now for the fun part.

Fun Part 1
I would love it so if you rank something as Number 1 - that is, change cell Bx to "1", it recalcs the rest of the list. (So whatever was already "1" becomes "2", whatever was already "2" becomes "3", etc.

Fun Part 1a
I'd love for that to work for ANY change in B. So if I make something "5", what was "5" becomes "6", what was "6" becomes "7", etc.

Fun Part 2
Oh, and then have it re-sort in 1-10 order.

Is this just a crazy fever dream of VBA and HTML run amok?

Thanks!

Your friend,
rjb

 

[offthelip]

I have it so Column B autopopulates 1-n based on whether or not A is blank.

you haven't told us how you are doing this, this could well influence the answer. What you are asking is possible with VBA
also what do you want to happen if you enter a ranking which is lower that the existing ranking e.g you change 5 to 6

 

[rjbinney]

you haven't told us how you are doing this, this could well influence the answer. What you are asking is possible with VBA
also what do you want to happen if you enter a ranking which is lower that the existing ranking e.g you change 5 to 6

Oh, I'm not married to how I did it. Just Bn =IF(ISBLANK(An),"",ROW()-1)

 

[offthelip]

I presume I can over write that, also you didn't answer:

also what do you want to happen if you enter a ranking which is lower that the existing ranking e.g you change 5 to 6

 

[offthelip]

Try thes two macros you need to put both of these in the worksheet module: Also you do NOT need your equation in column B the code will populate the number automatically:

Public lastsel As Variant    ' NOTE this must be at the top of the module

Private Sub Worksheet_Change(ByVal Target As Range)
If lastsel = "" Then
 Application.EnableEvents = False
 Cells(Target.Row, 2) = Target.Row - 1
Else
    If Target.Value < lastsel Then
      lastrow = Cells(Rows.Count, "A").End(xlUp).Row
      inarr = Range(Cells(1, 2), Cells(lastrow, 2))
      For i = 1 To lastrow
       If i <> Target.Row Then
        If inarr(i, 1) >= Target.Value And inarr(i, 1) < lastsel Then
         inarr(i, 1) = inarr(i, 1) + 1
        End If
       End If
      Next i
    Application.EnableEvents = False
     Range(Cells(1, 2), Cells(lastrow, 2)) = inarr
    Set myrange = Range(Cells(1, 1), Cells(lastrow, 2))
    Set Sortkey = Range(Cells(1, 2), Cells(lastrow, 2))
    myrange.Sort key1:=Sortkey, order1:=xlAscending, MatchCase:=False, Header:=xlNo
    End If
End If
 Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 Or Target.Column = 2 Then
    If Target.Count > 1 Then
      Cells(Target.Row, Target.Column).Select  ' force only a single cell to be selected
    End If
    lastsel = Cells(Target.Row, 2).Value ' save colum B value
End If

End Sub

Note you do need to have the declaration of Lastsel at the top of the module
since you didn't specify what to do if you enter a number greater than the existing one the code does nothing!!

 

[rjbinney]

since you didn't specify what to do if you enter a number greater than the existing one the code does nothing!!

Thanks! Willl try in the morning. I missed the second question - and I will have to think about the answer!

Thank you

 

[Tupe77]

Is this something like you need?
You may receive error messages in some situations. I will try to fix them then if this is otherwise suitable for your use.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim FirstRowOfData As Integer
FirstRowOfData = ActiveWorkbook.Worksheets(1).ListObjects(1).ListColumns(2).DataBodyRange.Row - 1
Dim Alue As Range: Set Alue = Range(ActiveWorkbook.Worksheets(1).ListObjects(1).ListColumns(2).DataBodyRange.Address)
Dim AiemmatARVOTrng As Range, tempRNG As Range, Cell As Range 'OK
Dim i As Integer, TargetROW2 As Integer: TargetROW2 = Target.Row - FirstRowOfData: Dim MaxExVal As Integer: MaxExVal = 0
Dim TargetVAL As Variant: TargetVAL = Target.Value

On Error GoTo ErrHand
If Intersect(Target, Range(ActiveWorkbook.Worksheets(1).ListObjects(1).ListColumns(2).DataBodyRange.Address)) Is Nothing Or Target.Cells.Count > 1 Then
   Exit Sub
Else

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For Each Cell In Alue
        If Not IsEmpty(Cell) And Not Cell.Address = Target.Address Then
            If AiemmatARVOTrng Is Nothing Then
                Set AiemmatARVOTrng = Cell
            Else
                Set AiemmatARVOTrng = Union(AiemmatARVOTrng, Cell)
            End If
        Else
        End If
    Next

    MaxExVal = Application.WorksheetFunction.Max(AiemmatARVOTrng)

    If TargetVAL = "" Then
        Select Case TargetROW2
            Case Is > MaxExVal
                'ok nothing to do
            Case Is < MaxExVal
                    If TargetROW2 = 1 Then
                        Set tempRNG = Range(Alue.Rows(TargetROW2 + 1).Address & ":" & AiemmatARVOTrng.Rows(AiemmatARVOTrng.Cells.Count).Address)
                    Else
                        Set tempRNG = Range(Alue.Rows(TargetROW2 + 1).Address & ":" & AiemmatARVOTrng.Rows(AiemmatARVOTrng.Cells.Count + 1).Address)
                    End If
                    '
                    Debug.Print "tempRNG.address = " & tempRNG.Address
                    For Each Cell In tempRNG
                        Cell.Value = Cell.Value - 1
                    Next
        End Select
    Else
        If TargetROW2 > AiemmatARVOTrng.Cells.Count Then
            Select Case TargetVAL
                Case Is > MaxExVal
                    Target.Value = MaxExVal + 1
                Case Is = MaxExVal
                    AiemmatARVOTrng.Rows(AiemmatARVOTrng.Rows.Count).Value = AiemmatARVOTrng.Rows(AiemmatARVOTrng.Rows.Count).Value + 1
                Case Is < MaxExVal
                    For i = AiemmatARVOTrng.Rows(Target.Value) To AiemmatARVOTrng.Rows(AiemmatARVOTrng.Rows.Count)
                        AiemmatARVOTrng.Rows(i).Value = AiemmatARVOTrng.Rows(i).Value + 1
                    Next
            End Select
        Else ' Target is Old Headers
            Select Case TargetVAL
                Case Is > TargetROW2 ' Target go down
                    If TargetVAL > MaxExVal Then Target.Value = MaxExVal: TargetVAL = Target.Value
                        For i = (TargetROW2 + 1) To TargetVAL
                            Alue.Rows(i).Value = Alue.Rows(i).Value - 1
                        Next
                Case Is < TargetROW2 ' Target go up
                    For i = Target.Value To (TargetROW2 - 1)
                        Alue.Rows(i).Value = Alue.Rows(i).Value + 1
                    Next
                Case Is = TargetROW2 ' Target do nothing
                    'ok nothing to do
            End Select
        End If
     End If
End If

ActiveWorkbook.Worksheets(1).ListObjects(1).ListColumns(2).DataBodyRange.Sort Key1:=ActiveSheet.ListObjects(1).HeaderRowRange(2), Header:=xlYes, Order1:=xlAscending

ErrHand:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Something went badly wrong!" & vbCrLf & "VBA-code is ended!" & vbCrLf & vbCrLf & "Error number: " & Err.Number & " " & Err.Description: End
End Sub

 

[Tupe77]

My code above is for use in a table, not just in columns.
It needs a table with two columns and headings to work.