按模板生成工作表

Option Explicit

Const Template$ = "客户基础档案资料"

Const NO$ = "序号"
Const SN$ = "代码"
Const Cos$ = "客户名称"
Const Per$ = "负责人"
Const Tel$ = "联系电话"
Const Adr$ = "地址"
Const Step$ = "业态"
Const Head$ = "归属经理"

Sub TemplateFill()
    Dim Ar(), I&, DTitle
    Set DTitle = CreateObject("Scripting.Dictionary")
    Ar = Sheet1.UsedRange
    For I = 1 To UBound(Ar, 2)
        DTitle(Ar(1, I)) = I
    Next I
    
    For I = 2 To UBound(Ar)
        With Sheets(Template)
            .Cells(3, 2) = Ar(I, DTitle(SN))
            .Cells(3, 4) = Ar(I, DTitle(Cos))
            .Cells(4, 2) = Ar(I, DTitle(Per))
            .Cells(4, 4) = Ar(I, DTitle(Tel))
            .Cells(5, 2) = Ar(I, DTitle(Adr))
            .Cells(6, 2) = Ar(I, DTitle(Step))
            .Cells(6, 4) = Ar(I, DTitle(Head))
            '.Cells(8, 2) = Ar(I, DTitle(Per))
        End With
        'Stop
        Call CopySht(Template, Ar(I, DTitle(NO)))
    Next I
End Sub


Sub CopySht(shtName$, NewShtName)
Application.DisplayAlerts = False
    Sheets(Template).Copy after:=Sheets(Sheets.Count)
    If SheetIsExist(NewShtName) Then
        Sheets("" & NewShtName).Delete
    End If
    Sheets(Sheets.Count).Name = NewShtName
Application.DisplayAlerts = True
End Sub

Function SheetIsExist(shtName) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets("" & shtName)
    SheetIsExist = (Err = 0)
    Err.Clear: On Error GoTo 0
End Function

 Sheet1：

Template：