Auto fill increment number in dynamic data ranges

user_15821340 0
Viewed 101

I am stuck in my vba code and seems I setup a loop wrong. Really appreciate for some advices! Thank you very much!!

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

Above is my code and now my VBA result is like this: screenshot

Column C is my ideal result of the code

vba excel
4 Answers

Please, try the next way:

Sub Countcode()
 Dim lastRow As Long, k As Long, rowPtr As Long

 lastRow = cells(rows.count, 1).End(xlUp).row
 k = 1
 For rowPtr = 2 To lastRow
    If Range("A" & rowPtr) = Range("A" & rowPtr + 1) Then
        Range("B" & rowPtr) = k: k = k + 1
    Else
        If Range("A" & rowPtr) = Range("A" & rowPtr - 1) Then
            Range("B" & rowPtr) = k: k=1
        Else
            k = 1
            Range("B" & rowPtr) = k
        End If
    End If
 Next
End Sub
user_22333080

Rank Reps (Repeating Values)

  • Adjust the values in the constants section.
  • Note that Range("A" & rowPtr) is the same as Cells(rowPtr, "A") or Cells(rowPtr, 1), and Range("A" & Rows.Count) is the same as Cells(Rows.Count, "A") or Cells(Rows.Count, 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
user_98140690

One approach is:

Sub numberIt2()
    Dim cl As Range, equal As Integer ' equal initial value is 0
    
    Set cl = Range("A1")
    Do While cl <> ""
        cl.Offset(0, 1) = equal + 1
        Set cl = cl.Offset(1)
        equal = IIf(cl = cl.Offset(-1), equal + 1, 0)
    Loop
End Sub

enter image description here

user_150353140 
Public Sub UpdateRankings(ByVal ws As Worksheet)

    ' Adjust as necessary.
    Const firstRow As Long = 3
    Const colGroupId As Long = 1
    Const colRanking As Long = 6
    
    Dim row As Long
    
    With ws
    
        ' First value defaults to 1.
        row = firstRow
        .Cells(row, colRanking).Value = 1

        ' Remaining rows.
        row = row + 1

        Do While .Cells(row, colGroupId).Value <> ""

            ' If group id is the same as the previous row, increment rank.
            If .Cells(row, colGroupId).Value = .Cells(row - 1, colGroupId).Value Then
                .Cells(row, colRanking).Value = .Cells(row - 1, colRanking).Value + 1

            ' If group id has changed, reset rank to 1.
            Else
                .Cells(row, colRanking).Value = 1

            End If

            ' Next row.
            row = row + 1

        Loop
        
    End With
    
End Sub
user_38170680
Related