Excel VBA求助：基于模板批量生成单元工作表并复制对应标记数据

修改后的完整代码 #

Sub CreateSheets()
    Dim rng As Range
    Dim cell As Range
    Dim srcSht As Worksheet ' 存储单元矩阵所在的源工作表
    Dim newSht As Worksheet ' 存储新生成的单元工作表
    Dim copyCol As Long ' 遍历施工项列用的变量
    Dim pasteRow As Long ' 新表内容粘贴的起始行号

    On Error GoTo Errorhandling

    ' 弹出框选择房间号所在单元格范围
    Set rng = Application.InputBox(Prompt:="选择房间号所在单元格范围:", _
    Title:="批量生成单元工作表", _
    Default:=Selection.Address, Type:=8)
    ' 记录单元矩阵所在的源工作表，避免后续跳转工作表后定位错误
    Set srcSht = rng.Parent

    For Each cell In rng
        ' 跳过空单元格
        If cell <> "" Then
            ' 复制模板工作表到指定位置
            Sheets("Template").Copy After:=Sheets("Unit Types")
            ' 直接绑定新生成的工作表，比依赖ActiveSheet更稳定
            Set newSht = Sheets(Sheets("Unit Types").Index + 1)
            ' 重命名新工作表
            newSht.Name = "UNIT-" & cell.Value
            
            ' ========== 以下是复制粘贴逻辑 ==========
            ' 方案1：直接复制当前房间号所在整行所有内容，粘贴到新表A1位置
            ' srcSht.Rows(cell.Row).Copy Destination:=newSht.Range("A1")
            
            ' 方案2：仅筛选复制标记为"X"的施工项，适配施工条目筛选需求
            pasteRow = 2 ' 假设模板第一行是表头，内容从第二行开始粘贴
            ' 假设施工项列范围为C列（第3列）到AZ列（第52列），可根据实际调整
            For copyCol = 3 To 52
                ' 当前单元格标记为X时，复制对应施工项到新表
                If srcSht.Cells(cell.Row, copyCol).Value = "X" Then
                    ' 复制施工项名称，假设列头在第4行，可根据实际调整行号
                    newSht.Cells(pasteRow, 1).Value = srcSht.Cells(4, copyCol).Value
                    ' 可自行补充复制施工要求、工期等其他字段的逻辑
                    pasteRow = pasteRow + 1
                End If
            Next copyCol
            ' ========== 复制粘贴逻辑结束 ==========
        End If
    Next cell

Errorhandling:
End Sub

代码说明 #

• 新增了工作表绑定逻辑，避免依赖ActiveSheet出现的偶发定位错误，兼容性更强
• 提供两种复制方案可按需选择：
  • 方案1直接整行复制，适合需要保留原行所有信息的场景
  • 方案2自动筛选当前单元标记为X的施工项，仅同步有效施工条目到新表，匹配原始需求
• 代码中标注了列范围、列头行号、粘贴起始位置的可调参数，可根据实际表格结构修改对应数值

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