基于B列动态值批量创建并重命名Excel工作表的VBA技术问询

需求与现有问题 #

针对B列中从B4开始的动态范围产品编码值，为每个值执行以下操作：

1. 复制现有“Order”工作表，将命名为“Symbol”的单元格(C2)替换为对应产品编码；
2. 将新工作表命名为该产品编码。

已完成部分代码逻辑，但不确定如何获取B列动态值集合并实现批量循环操作，现有代码片段如下：

##(1) get the range of values in column B starting from B4 (which is dynamic)


##(2) loop through all values in the column, create a sheet for each and change its name to the product

Dim SourceSheet As Object
Set SourceSheet = ActiveSheet
    
SourceSheet.Copy After:=SourceSheet
    
Dim NewSheet As Object
Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1)
    
On Error GoTo ERR_RENAME
NewSheet.Name = "InputName"
On Error GoTo 0

完整VBA实现代码 #

Sub GenerateProductSheets()
    Dim wsData As Worksheet
    Dim productRange As Range
    Dim productCell As Range
    Dim sourceOrderSheet As Worksheet
    Dim newSheet As Worksheet
    Dim lastRow As Long
    
    ' 设置数据所在工作表（假设产品编码在当前活动工作表，可根据实际修改）
    Set wsData = ActiveSheet
    
    ' 获取B列从B4开始的动态数据范围（直到最后一行非空单元格）
    lastRow = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row
    If lastRow < 4 Then
        MsgBox "B列从B4开始无有效产品编码数据！", vbExclamation
        Exit Sub
    End If
    Set productRange = wsData.Range("B4:B" & lastRow)
    
    ' 定位源"Order"工作表
    On Error Resume Next
    Set sourceOrderSheet = ThisWorkbook.Sheets("Order")
    On Error GoTo 0
    If sourceOrderSheet Is Nothing Then
        MsgBox "未找到名为""Order""的源工作表！", vbCritical
        Exit Sub
    End If
    
    ' 遍历每个产品编码
    For Each productCell In productRange
        ' 跳过空单元格
        If Trim(productCell.Value) <> "" Then
            ' 复制Order工作表到最后
            sourceOrderSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Set newSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            
            ' 修改命名单元格"Symbol"的值为当前产品编码
            On Error Resume Next
            newSheet.Range("Symbol").Value = productCell.Value
            On Error GoTo 0
            
            ' 重命名新工作表为产品编码
            On Error GoTo RenameError
            newSheet.Name = productCell.Value
            On Error GoTo 0
        End If
    Next productCell
    
    MsgBox "所有产品工作表已生成完成！", vbInformation
    Exit Sub
    
RenameError:
    MsgBox "产品编码 """ & productCell.Value & """ 对应的工作表重命名失败（可能名称重复或包含非法字符），已跳过该编码。", vbExclamation
    ' 删除重命名失败的工作表
    Application.DisplayAlerts = False
    newSheet.Delete
    Application.DisplayAlerts = True
    Resume Next
End Sub

关键代码说明 #

• 获取动态数据范围：通过Cells(Rows.Count, "B").End(xlUp).Row找到B列最后一行有数据的单元格，结合B4形成完整数据范围，同时判断如果最后一行小于4则提示无数据。
• 源工作表校验：先检查"Order"工作表是否存在，避免因工作表不存在导致报错。
• 循环处理逻辑：遍历每个产品编码单元格，跳过空值；复制源工作表后，通过命名单元格Range("Symbol")直接赋值，无需硬编码单元格位置。
• 错误处理：针对重命名失败（如名称重复、含非法字符）捕获错误，提示用户并删除无效工作表，保证程序持续运行。

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