请求修改Excel VBA装箱编码脚本：确保两科目始终同箱

需求说明 #

• 需为同书号的两个科目（English和Social & Religious Studies）生成唯一装箱编码，规则如下：
  1. 两个科目必须属于同一配送中心与同一学校；
  2. 单箱最多装300本书，同一配送中心下可混装多校图书，但每箱必须同时包含两个科目，且总数量不超过300；
  3. 若两科目总数量超过300，需在后续列（L到W）生成新箱码，且同校的两个科目必须匹配装箱。

原脚本问题 #

当前两段脚本执行时，第一段处理总数量≤300的装箱场景时，会将同一学校的两个科目拆分到不同箱子中，无法满足“两科目始终同箱”的核心要求。

修正后的第一段脚本（Stage1） #

Sub GenerateUniqueCode_Stage1()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim distCenter As String, school As String, subject As String
    Dim qtyEng As Long, qtySoc As Long, totalQty As Long
    Dim boxCounter As Long, totalBooksInBox As Long
    Dim boxCode As String
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    
    ' 初始化变量
    boxCounter = 1
    totalBooksInBox = 0
    ' 取第一个配送中心前缀生成初始箱码
    distCenter = Left(ws.Cells(2, "E").Value, 3)
    boxCode = distCenter & "BOXENGSOC" & Format(boxCounter, "000")
    
    ' 按学校成对处理（假设数据中English和Social行相邻且同校同配送中心）
    i = 2
    Do While i <= lastRow
        distCenter = ws.Cells(i, "E").Value
        school = ws.Cells(i, "G").Value
        subject = ws.Cells(i, "I").Value
        
        ' 跳过已标记为Excluded的行（避免重复处理）
        If ws.Cells(i, "K").Value = "Excluded" Then
            i = i + 1
            Continue Do
        End If
        
        ' 确认当前行是English，下一行是同校的Social
        If subject = "English" And ws.Cells(i + 1, "G").Value = school And ws.Cells(i + 1, "I").Value = "Social & Religious Studies" Then
            qtyEng = ws.Cells(i, "H").Value
            qtySoc = ws.Cells(i + 1, "H").Value
            totalQty = qtyEng + qtySoc
            
            ' 排除单科目数量≥100的学校
            If qtyEng >= 100 Or qtySoc >= 100 Then
                ws.Cells(i, "K").Value = "Excluded"
                ws.Cells(i + 1, "K").Value = "Excluded"
                i = i + 2
                Continue Do
            End If
            
            ' 判断当前箱子能否容纳这一对学校的书
            If totalBooksInBox + totalQty > 300 Or Left(distCenter, 3) <> Left(boxCode, 3) Then
                ' 新开箱子
                boxCounter = boxCounter + 1
                boxCode = Left(distCenter, 3) & "BOXENGSOC" & Format(boxCounter, "000")
                totalBooksInBox = totalQty
            Else
                totalBooksInBox = totalBooksInBox + totalQty
            End If
            
            ' 为两个科目分配同一箱码
            ws.Cells(i, "K").Value = boxCode
            ws.Cells(i + 1, "K").Value = boxCode
            
            i = i + 2
        Else
            ' 处理单独的行（异常数据）
            ws.Cells(i, "K").Value = "Invalid Pair"
            i = i + 1
        End If
    Loop
End Sub

第一段脚本修改点 #

1. 改为按学校成对处理，确保同一学校的English和Social科目始终被放在同一箱中；
2. 新增判断逻辑，先计算一对学校两个科目的总数量，再判断是否能加入当前箱子，否则直接新开箱子；
3. 优化箱码生成逻辑，确保配送中心前缀一致；
4. 增加异常数据标记，方便排查不符合成对规则的行。

修正后的第二段脚本（Stage2） #

Sub GenerateAdditionalUBCCode_Stage2_rev1()
    Dim ws As Worksheet
    Dim lastRow As Long, boxCounter As Long
    Dim ubcCode As String, distCenter As String
    Dim totalEnvCount As Long
    Dim i As Long, colIndex As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    
    ' 获取Stage1最后使用的箱号，确保箱号连续
    boxCounter = 1
    If ws.Cells(lastRow, "K").Value <> "" Then
        boxCounter = Val(Right(ws.Cells(lastRow, "K").Value, 3)) + 1
    End If
    
    ' 从L列开始处理（列号12）
    colIndex = 12
    Do While colIndex <= 23 ' W列是23
        i = 2
        Do While i <= lastRow
            ' 跳过ENV Count为0或已分配箱码的行
            If ws.Cells(i, "S").Value = 0 Or ws.Cells(i, colIndex).Value <> "" Then
                i = i + 1
                Continue Do
            End If
            
            ' 处理同校的English和Social配对
            If ws.Cells(i, "I").Value = "English" And ws.Cells(i + 1, "G").Value = ws.Cells(i, "G").Value _
               And ws.Cells(i + 1, "I").Value = "Social & Religious Studies" Then
               
                totalEnvCount = ws.Cells(i, "S").Value + ws.Cells(i + 1, "S").Value
                distCenter = Left(ws.Cells(i, "E").Value, 3)
                
                ' 根据总数量分配到对应列（每6个增量对应一列）
                Dim targetCol As Long
                targetCol = colIndex + Int((totalEnvCount - 1) / 6)
                If targetCol > 23 Then targetCol = 23 ' 不超过W列
                
                ' 生成箱码并赋值
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, targetCol).Value = ubcCode
                ws.Cells(i + 1, targetCol).Value = ubcCode
                
                boxCounter = boxCounter + 1
                i = i + 2 ' 跳过下一行的Social
            Else
                i = i + 1
            End If
        Loop
        colIndex = colIndex + 1
    Loop
    
    ' 清除K列的Excluded标记
    ws.Range("K2:K" & lastRow).Replace What:="Excluded", Replacement:="", LookAt:=xlWhole
End Sub

第二段脚本修改点 #

1. 优化箱号计数逻辑，直接提取Stage1最后箱码的数字部分，避免计数错误；
2. 简化列分配逻辑，用Int((totalEnvCount - 1)/6)计算目标列，替代冗余的多条件判断；
3. 增加列范围限制，确保不超过W列（23列）；
4. 用Replace方法批量清除K列的Excluded标记，提升效率；
5. 增加跳过已分配箱码行的逻辑，避免重复处理。

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