Forced Ranking Makro Excel VBA

Question

ich das Setup wie oben in der Abbildung dargestellt.

Logik des Makros ist, wenn ich eine Nummer 1 in Zelle B5 oder in leere Zelle in Range("B2:B26") geben Sie dann die Ausgabe in diesem Format sein würde:

B2 3 
B3 4 
B4 2 
B5 1 

Jetzt gibt es mir, dass die Ausgabe aber sicher sind, Nachteile z

Wenn ich die Eingabe 8 der gleichen Zelle zur Verfügung stelle, dann erhöht es immer noch die Ränge. Ich habe eine Übereinstimmungsprüfung durchgeführt, um zu sehen, ob dieser Wert vorhanden ist oder nicht, aber es scheint nicht zu funktionieren. Jede Hilfe wäre willkommen.

 Private Sub Worksheet_Change(ByVal Target As Range) 

     Application.ScreenUpdating = False 
     Application.EnableEvents = False 

      Dim KeyCells As Range 
      Dim i As Long, Cel As Range, sht1 As Worksheet, j As Long, found As Boolean 
      Set sht1 = Sheet1 

     Set KeyCells = sht1.Range("B2:C26") 
     If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then 

     If Target.Column = 2 Then 

      For i = 2 To 26 
       If sht1.Range("B" & i) <> Empty And sht1.Range("B" & i).Value >= Target.Value And i <> Target.Row Then 
         sht1.Range("B" & i).Value = sht1.Range("B" & i).Value + 1 
       Else: End If 
      Next i 
      Else: End If 


     If Target.Column = 3 Then 

      For i = 2 To 26 
       If sht1.Range("C" & i) <> Empty And sht1.Range("C" & i).Value >= Target.Value And i <> Target.Row Then 
         sht1.Range("C" & i).Value = sht1.Range("C" & i).Value + 1 
       Else: End If 
      Next i 


     Else: End If 


     Else: End If 
     Call CreateDataLabels 
     Target.Select 
     Application.ScreenUpdating = True 
     Application.EnableEvents = True 
End Sub 

Answer 1

Ist das, was Sie versuchen? Ich habe nicht ausgiebig getestet es

Option Explicit 

Dim rng As Range 

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim oldVal As Long, i as Long 

    On Error GoTo Whoa 

    Application.EnableEvents = False 

    Set rng = Range("B2:B26") 

    If Not Intersect(Target, rng) Is Nothing Then 
     oldVal = Target.Value 

     If NumExists(oldVal, Target.Row) = True Then 
      For i = 2 To 26 
       If i <> Target.Row And Range("B" & i).Value >= oldVal Then _ 
       Range("B" & i).Value = Range("B" & i) + 1 
      Next i 
     End If 
    End If 

Letscontinue: 
    Application.EnableEvents = True 
    Exit Sub 
Whoa: 
    MsgBox Err.Description 
    Resume Letscontinue 
End Sub 

Function NumExists(n As Long, r As Long) As Boolean 
    Dim i As Long 

    For i = 2 To 26 
     If Range("B" & i) = n And r <> i Then 
      NumExists = True 
      Exit Function 
     End If 
    Next i 
End Function 

Answer 2

bearbeitet „Helfer“ entfernen Werte

bearbeitet Funktionalität als auch für Spalte C die Lösung

Being Siddharth Rout Antwort hinzuzufügen, und mit Das OP ist nicht mehr gefragt, ich würde Folgendes als eine alternative Option vorschlagen, um möglicherweise zu diskutieren, wenn es sich lohnt zu erwägen

Option Explicit 

Private Sub Worksheet_Change(ByVal target As Range) 
    Dim oldVal As Long 
    Dim wrkRng As Range 

    Application.EnableEvents = False 
    On Error GoTo EndThis 

    If Continue(target, Range("B2:C26").Cells, oldVal, wrkRng) Then '<== here you set "B2:C26" as the "sensitive" range 
     With wrkRng 
      .Offset(, 2).Value = .Value 
      .FormulaR1C1 = "=IF(RC[2]<>"""",RC[2]+IF(and(RC[2]>=" & oldVal & ",ROW(RC)<>" & target.Row & "),1,0),"""")" 
      .Value = .Value 
      .Offset(, 2).ClearContents 
     End With 
    End If 

EndThis: 
    If Err Then MsgBox Err.Description 
    Application.EnableEvents = True 
    Exit Sub 
End Sub 

Function Continue(target As Range, rng As Range, oldVal As Long, wrkRng As Range) As Boolean 
    If target.Cells.Count = 1 Then 
     If Not IsEmpty(target) Then ' if cell has not been cancelled 
      Set wrkRng = Intersect(target.EntireColumn, rng) 
      If Not wrkRng Is Nothing Then 
       oldVal = target.Value 
       Continue = Application.WorksheetFunction.CountIf(wrkRng, oldVal) > 1 
      End If 
     End If 
    End If 
End Function 

zu Siddharth Rout-Lösung verglichen, verbessert es die folgenden:

• mehr (vollständig?) Prüfung als ob mit rng Verarbeitung

  in vorheriger Lösung geht auf

  • Wenn Sie eine Zelle in rng abgebrochen haben, würde es 1 in allen rng Zellen

  hinzufügen

  • wenn Sie Werte eingefügt in mehr als einem rng Zellen würde es einen Fehler

• keine Verwendung von Zellen, Iteration, sowohl für oldVal Zählen Zwecke werfen und für die Reihung der Aktualisierung