Adding a number to a list of unique but unordered numbers - Worksheet Change

Question

I have an excel file which contains a list of numbers in say Column A, and a list of names in Column B. The numbers are unique (no numbers are duplicated) but the numbers are not in order. It represents the order in which I need to contact them on a daily basis.

e.g.

3     John
2     Jane
5     James
1     Jonah
4     Jeremy

Here, I will contact Jonah, Jane, John, Jeremy and James in that order.

I plan to add a new person (Kate) to the list, and I plan to contact her 2nd. New list would look like this:

4     John
3     Jane
6     James
1     Jonah
5     Jeremy
2     Kate

Now, I will contact Jonah, KATE, Jane, John, Jeremy and James in that order. The important fact here is that all numbers below the new entry remain the same, but all numbers equal to or above the new entry increase by 1. Sometimes I will add new entries at the bottom of the list, other times I will add new entries by inserting a new row in the middle of the list. There will also be times when I need to take people out of the list, and I would like to reverse the event (for all numbers equal to or above the newly deleted number, they would have 1 subtracted from their original value).

I strongly suspect I need to set up a Worksheet Change event... the logic being something like this:

If a number is entered into the target range (in this case column A), Then all numbers in column A greater than or equal to the newly entered number will be the original value + 1.

If a number is deleted from the target range, Then all numbers in the target range greater than or equal to the newly entered number will be the original value - 1.

What is the best way to express this in VBA?

Many thanks in advance!

Answer 1

thanks for your help with my original question, and sorry for the delay.

i have used most of the code from tigeravatar, and modified it a bit, with a couple of additions. please find the below... seems to work.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngCheckA As Range, ATarget As Range, ACell As Range
Dim varBefore As Variant
Dim varAfter As Variant
Dim lChangeType As Long
Dim rngActive As Range

Set rngCheckA = Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))
Set rngActive = ActiveCell

Application.EnableEvents = False
On Error GoTo CleanExit

Set ATarget = Intersect(rngCheckA, Target)
If Not ATarget Is Nothing Then
    'Code only runs if a single cell in column A was changed
    If ATarget.Cells.Count = 1 Then
        'Get previous value
        Application.Undo
        varBefore = ATarget.Value

        'Get new value
        Application.Undo
        varAfter = ATarget.Value

        'Update list values appropriately based on how the list was changed
        For Each ACell In rngCheckA.Cells
            If IsNumeric(varAfter) And IsEmpty(varBefore) And ACell.Address <> ATarget.Address Then
                'add rank
                If Len(varBefore) = 0 And IsNumeric(varAfter) Then
                If ACell.Value >= ATarget.Value Then
                    ACell.Value = ACell.Value + 1
                End If
            ElseIf IsEmpty(varAfter) And IsNumeric(varBefore) And ACell.Address <> ATarget.Address Then
                'delete rank
                If Len(varAfter) = 0 And IsNumeric(varBefore) Then
                If ACell.Value > varBefore Then
                    ACell.Value = ACell.Value - 1
                End If
                End If
            ElseIf IsNumeric(varBefore) And IsNumeric(varAfter) And ACell.Address <> ATarget.Address Then
                'lower rank
                If varBefore > varAfter Then
                    If ACell.Value >= varAfter And ACell.Value < varBefore Then
                        ACell.Value = ACell.Value + 1
                    End If
                'raise rank
                ElseIf varBefore < varAfter Then
                    If ACell.Value <= varAfter And ACell.Value > varBefore Then
                        ACell.Value = ACell.Value - 1
                    End If
                End If
            End If
        Next ACell
    End If
End If

'In the event of any errors, turn EnableEvents back on
'The Application.Undo will change the selected cell, so set it back to what it was
CleanExit:
    Application.EnableEvents = True
    rngActive.Select

End Sub

This takes care of new rank entries, deleting rank entries, changing ranks from high to low, and low to high.

thanks for all your help!

Answer 2

Here is some commented code that should work for you:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngCheckA As Range, ATarget As Range, ACell As Range
    Dim varBefore As Variant
    Dim varAfter As Variant
    Dim lChangeType As Long
    Dim rngActive As Range

    Set rngCheckA = Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))
    Set rngActive = ActiveCell

    Application.EnableEvents = False
    On Error GoTo CleanExit

    Set ATarget = Intersect(rngCheckA, Target)
    If Not ATarget Is Nothing Then
        'Code only runs if a single cell in column A was changed
        If ATarget.Cells.Count = 1 Then
            'Get previous value
            Application.Undo
            varBefore = ATarget.Value

            'Get new value
            Application.Undo
            varAfter = ATarget.Value

            'Check how list changed
            If Len(varBefore) = 0 And IsNumeric(varAfter) Then
                'New value was added to the list
                lChangeType = 1
            ElseIf Len(varAfter) = 0 And IsNumeric(varBefore) Then
                'Existing value was removed (deleted) from list
                lChangeType = 2
            ElseIf IsNumeric(varBefore) And IsNumeric(varAfter) Then
                'Existing value in list was changed
                lChangeType = 3
            End If

            'Update list values appropriately based on how the list was changed
            For Each ACell In rngCheckA.Cells
                If Len(ACell.Value) > 0 And IsNumeric(ACell.Value) And ACell.Address <> ATarget.Address Then
                    'Only need to update values in list that are greater than or equal to the changed value
                    If ACell.Value >= ATarget.Value Then
                        Select Case lChangeType
                            Case 1: ACell.Value = ACell.Value + 1                               'New value added, increase values
                            Case 2: ACell.Value = ACell.Value - 1                               'Existing value removed, decrease values
                            Case 3: If ACell.Value = ATarget.Value Then ACell.Value = varBefore 'Existing value changed, swap numbers
                        End Select
                    End If
                End If
            Next ACell
        End If
    End If

'In the event of any errors, turn EnableEvents back on
'The Application.Undo will change the selected cell, so set it back to what it was
CleanExit:
    Application.EnableEvents = True
    rngActive.Select

End Sub

Answer 3

Okay, playing around with it, I was able to get the macro working when adding text. Insert this in the worksheet area (right click the worksheet tab, click "View Code"):

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Integer, newCallOrder As Integer, newEntryRow As Integer, newEntryVal As Integer
Dim orderCol As Integer, nameCol As Integer

orderCol = 1
nameCol = 2

Dim cel As Range, rng As Range

If Target.Columns.Count > 3 Then Exit Sub
If Target.Column = 1 And Target.Offset(0, 1).Value = "" Then Exit Sub
If Target.Column = 2 Then
 If Target.Offset(0, -1).Value = "" Then
    Exit Sub
 End If
End If

Application.EnableEvents = False

newEntryRow = Target.Row
newEntryVal = Cells(newEntryRow, orderCol).Value

Debug.Print "You added '" & newEntryVal & "' to row " & newEntryRow & "."

lastRow = ActiveSheet.UsedRange.Rows.Count
Set rng = Range(Cells(1, 1), Cells(lastRow, 1)) ' use lastRow - 1, to get existing range.
newCallOrder = Cells(lastRow, 1).Value

Dim checkNew As Integer
checkNew = WorksheetFunction.CountIf(rng, newEntryVal)

If checkNew > 0 Then

    For Each cel In rng
        If cel.Row <> newEntryRow Then
            cel.Select
            If cel.Value >= newEntryVal Then
                cel.Value = cel.Value + 1 '(cel.Value - newEntryVal)
            ElseIf newEntryVal < cel.Value Then
                cel.Value = cel.Value - 1
            End If
        End If
    Next cel
Else
    MsgBox ("No new order necessary")
End If

Application.EnableEvents = True

End Sub

(As I add this, two answers were posted). I'll go ahead and leave this here, in case there's a part of it you can feather into the other answers.

Answer 4

To contrast with @tigeravatar's solution, here's a very basic routine that assumes you're always entering a number in the last row of the range and does very little validation. Assumes numbers are being entered in column A.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column <> 1 Then Exit Sub
    If Target.Row <> Cells(Rows.Count, 1).End(xlUp).Row Then Exit Sub

    Application.EnableEvents = False

    ' Check each cell above and update if necessary...
    Dim r As Range
    For Each r In Range("A1:A" & Target.Row - 1)
        If r >= Target Then r = r + 1
    Next

    Application.EnableEvents = True

End Sub