如何修改VBA代码实现为选中区域每个单元格复制模板工作表并重命名

原代码仅处理**活动单元格（ActiveCell）**所在行的A列值，没有遍历选中的整个单元格区域。要实现批量处理选中区域的每个单元格，需要添加循环逻辑遍历选中区域，同时优化代码避免依赖Activate/Select（更稳定高效）。

修改后的代码：

Sub copyAndRename()
    Dim cell As Range
    Dim newSheet As Worksheet
    
    ' 遍历选中区域的每个单元格
    For Each cell In Selection
        ' 跳过空单元格（可选，根据需求调整）
        If IsDate(cell.Value) Then
            ' 复制模板工作表，返回新工作表对象
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set newSheet = ActiveSheet
            
            ' 设置新工作表名称和B6单元格值
            newSheet.Name = Format(cell.Value, "m-dd-yy")
            newSheet.Range("B6").Value = cell.Value
        End If
    Next cell
    
    ' 返回原工作表（可选）
    Sheets("Daily Averages").Activate
End Sub

关键改动说明： #

• 添加For Each cell In Selection循环，遍历选中区域的每一个单元格
• 使用IsDate(cell.Value)判断单元格是否为有效日期，避免非日期值导致错误（可根据需求移除）
• 用newSheet对象变量直接引用新建的工作表，替代ActiveSheet，避免激活操作带来的潜在问题
• 移除了不必要的Select操作，提升代码稳定性和运行效率

额外优化建议： #

可以添加错误处理，防止因重复工作表名导致代码崩溃：

Sub copyAndRenameWithErrorHandling()
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim sheetName As String
    
    On Error Resume Next ' 开启错误捕获
    For Each cell In Selection
        If IsDate(cell.Value) Then
            sheetName = Format(cell.Value, "m-dd-yy")
            ' 检查工作表是否已存在
            Sheets(sheetName).Activate
            If Err.Number = 0 Then
                Err.Clear
                MsgBox "工作表" & sheetName & "已存在，跳过该单元格", vbExclamation
                GoTo NextCell
            End If
            Err.Clear
            
            ' 复制模板并设置
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set newSheet = ActiveSheet
            newSheet.Name = sheetName
            newSheet.Range("B6").Value = cell.Value
        End If
NextCell:
    Next cell
    On Error GoTo 0 ' 关闭错误捕获
    
    Sheets("Daily Averages").Activate
End Sub

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