如何用Excel VBA实现分组内随机均分两类创意文本值？

核心逻辑说明 #

• 假设分组标识在A列（如A组、B组），创意文本写入B列
• 逐个处理每个分组：
  • 计算分组总行数，确定ROOMMATES15的数量为(总行数 + 1) \ 2（奇数行时多1个），FAMILY15为总行数 \ 2
  • 生成对应数量的创意数组，用洗牌算法打乱顺序，保证随机分布的同时严格满足数量要求

修改后的完整代码 #

Sub Soggetti()
    Dim wsPost As Worksheet
    Set wsPost = Sheets("test")
    
    Dim lRow As Long
    lRow = wsPost.Cells(Rows.Count, 1).End(xlUp).Row ' 获取数据最后一行
    
    Dim currentGroup As String
    Dim groupStartRow As Long
    Dim groupEndRow As Long
    Dim totalRowsInGroup As Long
    Dim countRoommates As Long
    Dim countFamily As Long
    Dim i As Long, j As Long
    Dim creativityArr() As String
    Dim tempStr As String
    Dim randomIndex As Integer
    
    ' 初始化第一个分组起始行（默认数据从第2行开始，第1行为表头）
    groupStartRow = 2
    currentGroup = wsPost.Cells(groupStartRow, 1).Value
    
    Do While groupStartRow <= lRow
        ' 定位当前分组的最后一行
        groupEndRow = groupStartRow
        Do While groupEndRow + 1 <= lRow And wsPost.Cells(groupEndRow + 1, 1).Value = currentGroup
            groupEndRow = groupEndRow + 1
        Loop
        
        ' 计算两类创意的分配数量
        totalRowsInGroup = groupEndRow - groupStartRow + 1
        countRoommates = (totalRowsInGroup + 1) \ 2
        countFamily = totalRowsInGroup \ 2
        
        ' 填充创意数组
        ReDim creativityArr(1 To totalRowsInGroup)
        For i = 1 To countRoommates
            creativityArr(i) = "ROOMMATES15"
        Next i
        For i = countRoommates + 1 To totalRowsInGroup
            creativityArr(i) = "FAMILY15"
        Next i
        
        ' Fisher-Yates洗牌算法打乱数组顺序
        For i = totalRowsInGroup To 2 Step -1
            randomIndex = Application.RandBetween(1, i)
            tempStr = creativityArr(i)
            creativityArr(i) = creativityArr(randomIndex)
            creativityArr(randomIndex) = tempStr
        Next i
        
        ' 将打乱后的数组写入B列
        wsPost.Range("B" & groupStartRow & ":B" & groupEndRow).Value = Application.Transpose(creativityArr)
        
        ' 切换到下一个分组
        groupStartRow = groupEndRow + 1
        If groupStartRow <= lRow Then
            currentGroup = wsPost.Cells(groupStartRow, 1).Value
        End If
    Loop
End Sub

关键改进点 #

• 新增分组遍历逻辑：自动识别A列的分组边界，逐个处理每个分组
• 替换随机分配方式：用洗牌算法保证随机分布，同时严格符合数量要求
• 适配大行数：将行号变量改为Long类型，避免数据量较大时出现溢出问题

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