excel - 自动填充动态数据范围内的增量数

Question

我被困在我的 vba 代码中，似乎我设置了一个错误的循环。非常感谢您的一些建议!非常感谢!!

Sub code()

Dim lastRow As Long
Dim k As Integer
Dim rowPtr As Long

lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For rowPtr = 2 To lastRow
     
If Range("A" & rowPtr + 1) <> Range("A" & rowPtr) Then
k = 1
Range("B" & rowPtr) = k

Else
        
If Range("A" & rowPtr + 1) = Range("A" & rowPtr) Then
Range("B" & rowPtr) = k
             
End If
k = k + 1
End If

Next
End Sub

上面是我的代码，现在我的 VBA 结果如下: screenshot

C 列是我理想的代码结果

Answer 1

排名代表(重复值)

• 调整常量部分中的值。
• 请注意，Range("A"& rowPtr) 与 Cells(rowPtr, "A") 或 Cells(rowPtr, 1) 和 Range("A"& Rows.Count) 与 Cells(Rows.Count, "A") 或 Cells(Rows .计数，1)。

Option Explicit

Sub rankReps()

    Const FirstRow As Long = 2
    Const sCol As String = "A"
    Const dCol As String = "B"
    
    Dim cOffset As Long: cOffset = Columns(dCol).Column - Columns(sCol).Column
    
    Dim LastRow As Long: LastRow = Range(sCol & Rows.Count).End(xlUp).Row
    If LastRow < FirstRow Then
         MsgBox "No data", vbCritical, "No Data"
         Exit Sub
    End If
    
    ' Write first.
    Range(sCol & FirstRow).Offset(, cOffset).Value = 1
    
    ' Write remainder.
    If LastRow > FirstRow Then
        Dim cCell As Range ' Current Cell
        Dim r As Long ' Row Counter
        Dim rk As Long: rk = 1 ' Rank Counter
        For r = FirstRow + 1 To LastRow ' +1: the first is already written
            Set cCell = Range(sCol & r)
            If cCell.Value = cCell.Offset(-1).Value Then
                rk = rk + 1
            Else
                rk = 1
            End If
            cCell.Offset(, cOffset).Value = rk
        Next r
    End If
    
End Sub