如何用VBA按扑克发牌规则填充Excel分组序列号？

场景说明 #

• A、B、C列存在数据，通过A列可计算总行数（当前示例为2120行）
• C列已预先填充001001-045001格式的编号：前3位为组号（最大值为45），后3位为序列号（初始均为001）
• 计算规则：每组最大基准序列号为(2120-1)\45=47，余数4归入最后一组，因此最后一组的最大序列号为47+4=51（对应编号045052）

填充规则 #

• 填充C列空白单元格时，不得覆盖已有内容，编号不可被其他空白单元格复用
• 采用扑克发牌的均衡轮询方式填充：起始序列号为002，第一个空白单元格填001002，第二个填002002……第47个填045002，第48个填001003，以此类推

完整VBA代码 #

Sub FillGroups()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim groupCount As Long
    Dim groupSize As Long
    Dim remainder As Long
    Dim currentSerial As Long
    Dim currentGroup As Long
    Dim blankCells As Collection
    Dim cell As Range
    Dim i As Long
    Dim maxGroup As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 获取最后一行数据的行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 提取6位字符串的前3位，找出最大组号，如"045001"→"045"
    maxGroup = "000"
    For i = 2 To lastRow
        If Left(ws.Cells(i, 3).Value, 3) > maxGroup Then
            maxGroup = Left(ws.Cells(i, 3).Value, 3)
        End If
    Next i
    groupCount = CLng(maxGroup)
    
    ' 计算每组的基准序列号数量和余数
    groupSize = (lastRow - 1) \ groupCount
    remainder = (lastRow - 1) Mod groupCount
    
    ' 收集所有C列的空白单元格（从第2行开始，跳过表头）
    Set blankCells = New Collection
    For i = 2 To lastRow
        If ws.Cells(i, 3).Value = "" Then
            blankCells.Add ws.Cells(i, 3)
        End If
    Next i
    
    ' 扑克发牌式填充逻辑
    currentSerial = 2 ' 起始序列号为002
    Do While blankCells.Count > 0
        For currentGroup = 1 To groupCount
            ' 确定当前组的最大序列号：最后remainder组多分配余数部分
            Dim maxSerialForGroup As Long
            maxSerialForGroup = groupSize
            If currentGroup > groupCount - remainder Then
                maxSerialForGroup = maxSerialForGroup + 1
            End If
            
            ' 当前组已达最大序列号则跳过
            If currentSerial > maxSerialForGroup Then
                Continue For
            End If
            
            ' 生成6位格式的编号
            Dim newID As String
            newID = Format(currentGroup, "000") & Format(currentSerial, "000")
            
            ' 填充第一个空白单元格并从集合移除
            If blankCells.Count > 0 Then
                Set cell = blankCells(1)
                cell.Value = newID
                blankCells.Remove 1
            Else
                Exit Do
            End If
        Next currentGroup
        currentSerial = currentSerial + 1
    Loop
End Sub

代码说明 #

1. 空白单元格收集：先遍历C列将需要填充的空白单元格存入集合，避免重复遍历查找
2. 轮询逻辑：从序列号002开始，依次为每个组分配当前序列号的编号，直到该组达到最大序列号上限
3. 组上限控制：最后remainder个组的最大序列号为groupSize+1，其余组为groupSize，确保余数正确分配到末尾组
4. 格式保证：用Format函数自动补前导零，确保编号始终为00X00X的6位格式

内容的提问来源于stack exchange，提问作者markex