批量复刻模板表并指定表名

Sub 工作表按模板复制拆分()
    '----------------------------------------------------
     '自定义各数据类型
    Dim Splitcol, rng As Range
    Dim Colnum As Integer, Arr, Lastrow, i, Shtindex, Only As New Collection
    
    On Error Resume Next
    '-----------------------------------------------------
    '指定需要的拆分条件列
    Set Splitcol = Application.InputBox("选择单位所属的单元格区域", "选择单位", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    If WorksheetFunction.CountA(Splitcol.EntireColumn) = 0 Then MsgBox "选择的列内容为空": Exit Sub
    '-----------------------------------------------------
    On Error GoTo 0
    
    
    With Splitcol.Parent
        Colnum = Splitcol.Column
        Lastrow = .UsedRange.Rows.Count
        
        '-------------------------------------------------
        '对需要拆分的条件列的值剔除重复值，利用Colection有序集合的成员不能存在重复内容的作用
        Arr = .Range(.Cells(7, Colnum), .Cells(Lastrow, Colnum))
        On Error Resume Next
        For i = 1 To Lastrow - 7
            If Len(Arr(i, 1)) > 0 Then Only.Add CStr(Arr(i, 1)), CStr(Arr(i, 1))
        Next i
        
        
        Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度
        Application.DisplayAlerts = False  '关闭显示特定的警告和消息，删除已经存在相同名字的工作表时，不弹出消息
        
        For i = 1 To Only.Count
            Err.Clear
            Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Sheets(Sheets.Count).Name = Only(i)
            If Err.Number > 0 Then Sheets(Only(i)).Delete: Sheets(Sheets.Count).Name = Only(i)
            
        Next i
        
        '------------------------------------------------
        '遍历拆分出的工作表，把明细表众的相应内容拆分到各分表中
        
        For i = 1 To Only.Count
            Shtindex = 7
            Sheets("表模板").Cells.Copy
            Sheets(Only(i)).Paste
            For Each rng In Splitcol
                If rng = Only(i) Then
                    ThisWorkbook.Sheets(Only(i)).Cells(Shtindex, 4) = rng.Offset(0, -3)
                    ThisWorkbook.Sheets(Only(i)).Cells(Shtindex, 1) = rng.Offset(0, 1)
                    Shtindex = Shtindex + 1
                End If
            Next rng
            
        Next i
        .AutoFilterMode = False
   End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ThisWorkbook.Save
    MsgBox "完成"

End Sub
1：按照表模板批量复制生成工作表
2：自主修改部分代码做成小的应用
3：模板的已有内容亦可复制后按指定条件填充
源码视频演示
批量复刻模板表并指定表名(内容填充)

目录
