Forced rank list of values

P

PATSYS

Well-known Member
Joined
Mar 12, 2006
Messages
1,750
Hi all,

Is it possible to force rank values in Excel, similar to the way columns are forced rank in a Sharepoint list?

So if I have the following values in range A1:A4 (the range have data validation, only allowing values 1 -4)

1
2
3
4

If the user changes A3 to 2, then the A2 will automatically become 3.

I'd imagine thisis done thru VBA.

Thanks in advance.
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
There's probably a smarter way of doing this (i.e., without loops) but this seems to work. I wanted to avoid trouble so if there's missing numbers, blank cells, or other "problems" it should hopefully do "nothing". Not really meant for large numbers of numbers (just a few dozen or so - there's a lot of copying of string variables in this routine)

Code: 
[COLOR="Navy"]Private[/COLOR] [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] sTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    
    [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] Intersect(Target, Range("_MyRange")) [COLOR="Navy"]Is[/COLOR] [COLOR="Navy"]Nothing[/COLOR] [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Target.Count = 1 [COLOR="Navy"]Then[/COLOR] [COLOR="SeaGreen"]'//multi-cell changes are ignored[/COLOR]
    
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] c [COLOR="Navy"]In[/COLOR] Range("_MyRange").Cells
                [COLOR="Navy"]If[/COLOR] c.Value = Target.Value [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] c.Address <> Target.Address [COLOR="Navy"]Then[/COLOR]
                        sTemp = newRank
                        [COLOR="Navy"]If[/COLOR] sTemp <> "" [COLOR="Navy"]Then[/COLOR]
                            Application.EnableEvents = False
                            c.Value = sTemp
                            Application.EnableEvents = True
                        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
            [COLOR="Navy"]Next[/COLOR] c
            
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Function[/COLOR] newRank() [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] Range, r [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] s [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


    [COLOR="Navy"]Set[/COLOR] r = Range("_MyRange")
    
    [COLOR="SeaGreen"]'//Rank 1 to Count of Cells[/COLOR]
    [COLOR="Navy"]For[/COLOR] i = 1 [COLOR="Navy"]To[/COLOR] 4
        s = s & " " & i & " "
    [COLOR="Navy"]Next[/COLOR] i
    
    [COLOR="SeaGreen"]'//Strip out all values until only the missing value remains[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] c [COLOR="Navy"]In[/COLOR] r
        s = Replace(s, " " & c.Value & " ", "", 1, 1)
    [COLOR="Navy"]Next[/COLOR] c

    [COLOR="SeaGreen"]'//If more than one missing value or no missing value then no return value[/COLOR]
    [COLOR="Navy"]If[/COLOR] Len(s) - Len(Trim(s)) = 2 [COLOR="Navy"]Then[/COLOR]
        newRank = s
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Function[/COLOR]
 
Last edited:
Upvote 0
xenou said:
There's probably a smarter way of doing this (i.e., without loops) but this seems to work. I wanted to avoid trouble so if there's missing numbers, blank cells, or other "problems" it should hopefully do "nothing". Not really meant for large numbers of numbers (just a few dozen or so - there's a lot of copying of string variables in this routine)

Code: 
[COLOR="Navy"]Private[/COLOR] [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] sTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    
    [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] Intersect(Target, Range("_MyRange")) [COLOR="Navy"]Is[/COLOR] [COLOR="Navy"]Nothing[/COLOR] [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Target.Count = 1 [COLOR="Navy"]Then[/COLOR] [COLOR="SeaGreen"]'//multi-cell changes are ignored[/COLOR]
    
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] c [COLOR="Navy"]In[/COLOR] Range("_MyRange").Cells
                [COLOR="Navy"]If[/COLOR] c.Value = Target.Value [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] c.Address <> Target.Address [COLOR="Navy"]Then[/COLOR]
                        sTemp = newRank
                        [COLOR="Navy"]If[/COLOR] sTemp <> "" [COLOR="Navy"]Then[/COLOR]
                            Application.EnableEvents = False
                            c.Value = sTemp
                            Application.EnableEvents = True
                        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
            [COLOR="Navy"]Next[/COLOR] c
            
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Function[/COLOR] newRank() [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] Range, r [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] s [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


    [COLOR="Navy"]Set[/COLOR] r = Range("_MyRange")
    
    [COLOR="SeaGreen"]'//Rank 1 to Count of Cells[/COLOR]
    [COLOR="Navy"]For[/COLOR] i = 1 [COLOR="Navy"]To[/COLOR] 4
        s = s & " " & i & " "
    [COLOR="Navy"]Next[/COLOR] i
    
    [COLOR="SeaGreen"]'//Strip out all values until only the missing value remains[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] c [COLOR="Navy"]In[/COLOR] r
        s = Replace(s, " " & c.Value & " ", "", 1, 1)
    [COLOR="Navy"]Next[/COLOR] c

    [COLOR="SeaGreen"]'//If more than one missing value or no missing value then no return value[/COLOR]
    [COLOR="Navy"]If[/COLOR] Len(s) - Len(Trim(s)) = 2 [COLOR="Navy"]Then[/COLOR]
        newRank = s
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Function[/COLOR]
Click to expand...

Hi Xenou,

Many thanks for your post. I actually gave up on this and decided not to use Excel for that specific purpose.

But anyhow this is still of interest to me and tried your code.

It did work for some instances but not in the case when the origina arrangement is

1
4
2
3

If I change the 2nd item (4) to 2, what the code did was this:

1
2
4
3

It really should be:

1
2
3
4

the rationale being that by changing the 4 to 2, the highest value 4 should be assigned to the next highest valuewhich is 3, not 2.
 
Upvote 0
Okay, I was using a simpler algorithm of just "switching" places - 4 becomes 2 so 2 becomes 4. Since you have another way of tackling this now I guess it's moot :)

Cheers.
 
Upvote 0
Try this:

Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("_MyRange")) Is Nothing Then

        If Target.Value <> Target.Offset(-1,0).Value Mod 4 + 1 Then
            Application.Undo
        End If

    End If

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Capturing Highest Historical Rank in a Continuously Updated Worksheet
2
Replies
11
Views
350
Mz309Lord
M
R
  • Solved
Ranking Absolute Deviation from Targeted Value
Replies
2
Views
175
rkeen0822
R
N
  • Question
Auto Sort for Leaderboard
Replies
0
Views
103
NTLKnight
N
M
  • Question
Dynamic Update to Range in RANK Based on Date
Replies
0
Views
253
multifidus
M
D
  • Solved
Updating rank order while cutting and pasting rows
Replies
3
Views
297
kevin9999
K

Forum statistics

Threads
1,214,979
Messages
6,122,559
Members
449,089
Latest member
Motoracer88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top