Добавление числа в список уникальных, но неупорядоченных чисел - Изменение рабочего листа

Question

У меня есть файл excel, который содержит список чисел в колонке A и список имен в столбце B. Цифры уникальны (числа не являются дублируются), но цифры не в порядке. Он представляет собой порядок, в котором я должен связаться с ними ежедневно.

например.

3  John 
2  Jane 
5  James 
1  Jonah 
4  Jeremy 

Здесь я свяжусь с Иона, Джейн, Иоанн, Джереми и Джеймсом в этом порядке.

Я планирую добавить нового человека (Кейт) в список, и я планирую связаться с ней 2-го. Новый список будет выглядеть следующим образом:

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

Теперь я свяжусь Иону, КЕЙТ, Джейн, Джон, Джереми и Джеймс в таком порядке. Важным фактом здесь является то, что все числа ниже новой записи остаются неизменными, но все числа, равные или превышающие новую запись, увеличиваются на 1. Иногда я буду добавлять новые записи в нижней части списка, иначе я добавлю новые записи добавив новую строку в середине списка. Также будут случаи, когда мне нужно вывести людей из списка, и я хотел бы обратить вспять событие (для всех чисел, равных или превышающих недавно удаленный номер, они будут иметь 1 вычитаемое из их исходного значения).

Я сильно подозреваю, что мне нужно, чтобы создать рабочий лист Изменить событие ... логика в том, что-то вроде этого:

Если номер вводится в целевом диапазоне (в данном случае колонки А), Тогда все номера в столбце A, превышающие или равные только что введенному номеру, будут оригинальным значением + 1.

Если число удалено из целевого диапазона, то все числа в целевом диапазоне больше или равны новому введенный номер будет исходным значением - 1.

W шляпа - лучший способ выразить это в VBA?

Большое спасибо заранее!

Answer 1

Вот некоторый прокомментировал код, который должен работать для вас:

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 2

контрастировать с @ tigeravatar решением которого, вот очень простая процедура, которая предполагает, что вы всегда ввод номера в последней строке диапазона и делает очень мало подтверждения. Предполагает, что числа вводятся в колонку 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 

Answer 3

Хорошо, играя с ним, я смог заставить макрос работать при добавлении текста. Вставьте это в области рабочего листа (правой кнопкой мыши вкладку листа, нажмите «Просмотр кода»):

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 

(Как добавить это, два ответа были опубликованы). Я пойду вперед и оставлю это здесь, если есть часть этого, вы можете перенести в другие ответы.

Answer 4

спасибо за помощь с моим оригинальным вопросом и извините за задержку.

Я использовал большую часть кода от tigeravatar, и немного изменил его, добавив пару дополнений. пожалуйста, найдите ниже ... кажется, работает.

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 

Это заботится о новых записях ранга, удаление записей ранга, меняя ряды от высокой к низкой и низкой до высокой.

благодарит за вашу помощь!