Excel VBA按列表批量生成模板工作表并填充数据问题求解

• Excel初始包含2个工作表：
  • List工作表：存储姓名、编号、产品编号三类数据
  • Template模板工作表

• 复制Template模板工作表，将对应行的姓名、编号、产品信息填入新工作表，通过ActiveSheet.Name = Range("B3").Value语句将新工作表重命名为B3单元格的值
• 逐行向下遍历列表数据重复上述操作，直到所有数据行处理完毕
• 若已存在同名工作表，直接跳过当前行，处理下一条数据

方案1：无循环硬编码 #

存在问题：

• 未使用循环结构，处理近100行数据需要重复粘贴修改了行号的相同代码，维护成本极高
• 遇到已存在的同名工作表时宏会直接停止运行，无法继续执行后续操作，多次尝试添加“同名则跳过”的逻辑均导致运行报错
  对应代码：

Sub TemplateMultiple()
'
' Tab creation and naming
'

'
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(2)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!RC[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(3)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[0]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(4)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[4]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[1]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(5)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[5]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(6)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[6]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[4]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
End Sub

方案2：循环结构 #

存在问题：

• 代码可读性和易维护性优于方案1，但所有新生成的模板工作表都填充了相同数据，没有逐次读取列表下一行的数据进行填充
  对应代码：

Sub Template1()
'UpdatebyExtendoffice20161222
    Dim x As Integer
    Application.ScreenUpdating = False
    ' Set numrows = number of rows of data.
    NumRows = Range("B5", Range("B5").End(xlDown)).Rows.Count
    ' Select cell a1.
    Range("B5").Select
    ' Establish "For" loop to loop "numrows" number of times.
    For x = 1 To NumRows
        ' Insert your code here.
        Sheets("Template").Select
        Sheets("Template").Copy Before:=Sheets(2)
        Range("B3:C3").Select
        ActiveCell.FormulaR1C1 = "='List'!R[2]C"
        Range("B5:C5").Select
        ActiveCell.FormulaR1C1 = "='List'!RC[3]"
        Range("B6:C6").Select
        ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
        Range("B7:C7").Select
        ActiveSheet.Name = Range("B3").Value
        ' Selects cell down 1 row from active cell.
        ActiveCell.Offset(1, 0).Select
    Next
    Application.ScreenUpdating = True
End Sub

Sub GenerateSheetsFromTemplate()
    Dim wsList As Worksheet, wsTemplate As Worksheet, wsNew As Worksheet, ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim sheetName As String
    Dim sheetExists As Boolean
    
    ' 关闭屏幕更新和弹窗提示，提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 绑定工作表对象，避免Select操作
    Set wsList = ThisWorkbook.Worksheets("List")
    Set wsTemplate = ThisWorkbook.Worksheets("Template")
    
    ' 获取List表B列最后一行数据行号
    lastRow = wsList.Cells(wsList.Rows.Count, "B").End(xlUp).Row
    
    ' 从第5行开始遍历数据（匹配原代码的数据起始行）
    For i = 5 To lastRow
        ' 先获取当前行要生成的工作表名称（对应新表B3的值，即List表B列当前行的姓名）
        sheetName = wsList.Cells(i, "B").Value
        
        ' 检查是否存在同名工作表
        sheetExists = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = sheetName Then
                sheetExists = True
                Exit For
            End If
        Next
        
        ' 同名则跳过当前行
        If sheetExists Then GoTo NextRow
        
        ' 复制模板到第二个工作表位置
        wsTemplate.Copy Before:=ThisWorkbook.Worksheets(2)
        Set wsNew = ActiveSheet
        
        ' 动态填充公式，直接引用List表当前行，避免偏移量计算错误
        wsNew.Range("B3:C3").FormulaR1C1 = "='List'!R" & i & "C"
        wsNew.Range("B5:C5").FormulaR1C1 = "='List'!R" & i & "C[3]"
        wsNew.Range("B6:C6").FormulaR1C1 = "='List'!R" & i & "C[4]"
        
        ' 重命名新工作表
        wsNew.Name = sheetName
        
NextRow:
    Next i
    
    ' 恢复屏幕更新和弹窗提示
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "工作表生成完成", vbInformation
End Sub

关键修改说明 #

• 移除了所有Select/Activate焦点切换操作，直接绑定工作表对象操作，避免引用错位
• 新增同名工作表检测逻辑，检测到同名时直接跳过当前行，不会中断宏运行
• 循环中直接根据List表的当前行号动态生成R1C1公式，保证每一行数据准确填充到对应新工作表，不会出现所有表数据相同的问题
• 增加了运行状态提示，批量处理完成后弹出完成提醒
• 补充了DisplayAlerts关闭逻辑，避免复制工作表时弹出不必要的系统提示

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