Auto Calc/Sort Validation List

[Mike54]

When I started this two days ago I thought this would be easy, well that was my first mistake.

Range A1:A6 is populated with a valid list, the options are 1 to 6. so the initial set up is A1=1, A2=2.................A6=6.

In the ajacent column (B1:B6) are six names

If I change the value in column A from say 2 to 4 I woud like the system to balance & sort itself and the names into the new heirarchy

1 - Mark 1 - Mark 1 - Mark
2 - Kate 4 - Kate 2 - John
3 - John 3 - John 3 - Mike
4 - Mike 4 - Mike 4 - Kate
5 - Mary 5 - Mary 5 - Mary
6 - Jane 6 - Jane 6 - Jane

I've tried adding & subtracting total values, there are too many ways to add to 21, Ive tried various For Each, For Next loops & bubble sorts all without sucess.

I've seached the forum, but phrasing the right question is very difficult.

Any help would be fantastic, thanks

Mike
PS
This is NOT homework this is a real project of mine I just using replacement junk data for obvious reasons.

 

[Jerry Sullivan]

Mike,

Is there any reason that you can't just use VBA's Range.Sort Method to sort by Column A?

Did you want to sort every time that a value is changed in Column A, or would you rather let the user edit multiple values then click a button to sort? I believe the latter is more common so the user doesn't have to keep re-orienting to a moving target.

 

[Mike54]

Hi Jerry thanks for posting, that's food for thought I'll look at the range sort method, I just believed that I'd be able to do the maths fairly easily & then it beacme an issue.

I follow your reasoning around muliple entries but experience has shown that we end up with duplicate entries, hence the plan not only to sort the items but automatically adjust the other entries position/number.

With the range sort method I could end up with 1,2,4,4,5,6 couldn't I

Regards

Mike

Using Excel 2010 at Home & 97-03 at Work

 

[Mike54]

I got this working, but it's not very good it & still allows duplicate entries, it also fails to promote or demote, just highlights.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Amax As Integer
Dim i As Integer, j As Integer
Dim text1 As Variant
Dim text2 As Variant
Dim text3 As Variant
Dim text4 As Variant


Amax = 6
For i = 1 To Amax - 1

For j = i + 1 To Amax
text1 = Cells(i, 1).Value
text2 = Cells(j, 1).Value
text3 = Cells(i, 2).Value
text4 = Cells(j, 2).Value

If text2 < text1 Then

Cells(i, 1).Value = text2
Cells(j, 1).Value = text1
Cells(i, 2).Value = text4
Cells(j, 2).Value = text3

End If
Next j
Next i


Dim C As Range

For Each C In Range("A1:A6")

C.Interior.ColorIndex = 2

If C.Offset(1, 0) = C Then
C.Interior.ColorIndex = 3
End If
Next
End Sub

I'm sure i've seen or used something similar in the past, except their's worked properly!
Mike

 

[Jerry Sullivan]

Mike,

If you can adopt a couple of rules (which look consistent with your intent)

1. Start with your list in ascending order
2. Change only one cell at at time
3. The value entered must be from 1-6 (or Amax)
4. Re-sort the list after any change in values

...then this code might give you the results you've described.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A1:A6")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    Dim i As Long, lngOld As Long
    Dim lngShift As Long: lngShift = 1
    Dim rngRank As Range: Set rngRank = Range("A1:A6")
    On Error GoTo CleanUp
    With rngRank
        If Target > .Rows.Count Then Exit Sub
        For i = 1 To .Rows.Count
            If .Cells(i) <> i And .Cells(i).Row <> Target.Row Then
                MsgBox "Exiting...ranks had incorrect starting order"
                Exit Sub
            End If
        Next i
        lngOld = Target.Row - .Row + 1
        If Target = lngOld Then Exit Sub
        If Target < lngOld Then lngShift = -1
 
        Application.EnableEvents = False
        For i = lngOld + lngShift To Target Step lngShift
            .Cells(i) = i - lngShift
        Next
        With .Parent.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rngRank(1), _
                SortOn:=xlSortOnValues, Order:=xlAscending
            .SetRange rngRank.Resize(, 2)
            .Header = xlNo
            .Orientation = xlTopToBottom
            .Apply
        End With
    End With
CleanUp:
    Set rngRank = Nothing
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

The code checks to make sure the rules above are followed and exits if
there is an exception (like 2 cells changed at the same time through a Copy-Paste).

It wasn't clear to me which cells you were trying to color.
That could be added if you describe that a bit more.

 

[Mike54]

Jerry, that's brilliant. Thanks very much for taking the time & trouble to write that code, it will be very helpful. I feel I've learnt quite a bit from you here although some of it is a little beyond me at present.

I like the way you have built in methods to prevent errors or warn of them.

My colour coding was merely there to highlight duplicate entries; your code makes that unnecessary.

Many thanks Jerry

Mike

 

[Jerry Sullivan]

Mike, I'm very happy to have helped and it was a fun puzzle.
If you have any questions on how any parts work - just ask and I'll try to explain.