将数字添加到唯一但无序的数字列表 – 工作表更改
我有一个Excel文件，其中包含列A中的数字列表和列B中的名称列表。这些数字是唯一的（没有数字是重复的），但数字不是按顺序排列的。 它代表我需要每天与他们联系的顺序。
例如
3 John 2 Jane 5 James 1 Jonah 4 Jeremy 在这里，我将按顺序联系乔纳，简，约翰，杰里米和詹姆斯。
我打算在名单上增加一个新人（凯特），我计划与她联系。 新的列表将如下所示：
4 John 3 Jane 6 James 1 Jonah 5 Jeremy 2 Kate
现在，我将按顺序联系乔纳，凯特，简，约翰，杰里米和詹姆斯。 这里的重要事实是新条目下面的所有数字都保持不变，但是所有等于或高于新条目的数字都会增加1.有时，我会在列表底部添加新条目，其他时候我会添加新条目通过在列表中间插入一个新的行。 也有些时候我需要把人排除在外，而且我想要改变这个事件（对于所有等于或大于新删除的数字的数字，他们会从原始值中减去1）。
我强烈怀疑我需要build立一个工作表变更事件…逻辑是这样的：
如果一个数字被input到目标范围内（在这种情况下是列A），那么A列中所有大于或等于新input数字的数字将是原始数值+ 1。
如果从目标范围中删除一个数字，那么目标范围内所有大于或等于新input数字的数字将是原始数值-1。
在VBA中expression这个最好的方法是什么？
提前谢谢了！
以下是一些应该适合您的注释代码：
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
与@ tigeravatar的解决scheme相比，下面是一个非常基本的例程，假设您总是在范围的最后一行input一个数字，并且只进行很less的validation。 假设数字正在列A中input
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
好吧，玩这个游戏的时候，我可以在添加文字的时候使用macros。 将其插入工作表区域（右键单击工作表选项卡，单击“查看代码”）：
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
（正如我补充一样，发布了两个答案）。 我会继续留在这里，以防止其中的一部分，你可以羽毛到其他的答案。
感谢您对我原来的问题的帮助，并对延误表示歉意。
我已经使用了tigeravatar的大部分代码，并对其进行了一些修改，添加了一些新function。 请find下面…似乎工作。
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
这将照顾新的等级条目，删除等级条目，将等级从高到低，从低到高。
感谢你的帮助！