強制排名宏excel vba

Question

我的安裝如上圖所示。

邏輯宏的是，如果我在細胞B5或在Range("B2:B26")空單元格中輸入一個數字1則輸出將是這種格式：

B2 3 
B3 4 
B4 2 
B5 1 

現在，它給我的輸出，但也有一定的缺點例如

如果我提供輸入8到同一個單元，那麼它仍然會增加排名。我加入了一個匹配檢查，看看這個值是否存在，但它似乎不工作任何幫助，將不勝感激。

 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

這是你在想什麼？我還沒有廣泛地測試它

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

編輯刪除「幫手」的價值觀

編輯爲C列添加功能以及

是亞洲時報Siddharth潰敗的答案的解決方案，並具有OP沒有要求任何更多，我會建議以下作爲備選方案，可能討論如果值得考慮

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 

相比，亞洲時報Siddharth潰敗的解決方案，它增強了以下內容：

• 以上（完成？）測試，如果在之前的解決方案與rng處理

  去

  • 如果您取消了rng中的某個單元格，則會在所有rng單元格中添加1單元格

  • ，如果你在一個以上rng細胞粘貼值它會拋出一個錯誤

• 沒有用細胞迭代，既爲oldVal計數目的和排名更新