按模板生成工作表

 1 Option Explicit
 2 
 3 Const Template$ = "客户基础档案资料"
 4 
 5 Const NO$ = "序号"
 6 Const SN$ = "代码"
 7 Const Cos$ = "客户名称"
 8 Const Per$ = "负责人"
 9 Const Tel$ = "联系电话"
10 Const Adr$ = "地址"
11 Const Step$ = "业态"
12 Const Head$ = "归属经理"
13 
14 Sub TemplateFill()
15     Dim Ar(), I&, DTitle
16     Set DTitle = CreateObject("Scripting.Dictionary")
17     Ar = Sheet1.UsedRange
18     For I = 1 To UBound(Ar, 2)
19         DTitle(Ar(1, I)) = I
20     Next I
21     
22     For I = 2 To UBound(Ar)
23         With Sheets(Template)
24             .Cells(3, 2) = Ar(I, DTitle(SN))
25             .Cells(3, 4) = Ar(I, DTitle(Cos))
26             .Cells(4, 2) = Ar(I, DTitle(Per))
27             .Cells(4, 4) = Ar(I, DTitle(Tel))
28             .Cells(5, 2) = Ar(I, DTitle(Adr))
29             .Cells(6, 2) = Ar(I, DTitle(Step))
30             .Cells(6, 4) = Ar(I, DTitle(Head))
31             '.Cells(8, 2) = Ar(I, DTitle(Per))
32         End With
33         'Stop
34         Call CopySht(Template, Ar(I, DTitle(NO)))
35     Next I
36 End Sub
37 
38 
39 Sub CopySht(shtName$, NewShtName)
40 Application.DisplayAlerts = False
41     Sheets(Template).Copy after:=Sheets(Sheets.Count)
42     If SheetIsExist(NewShtName) Then
43         Sheets("" & NewShtName).Delete
44     End If
45     Sheets(Sheets.Count).Name = NewShtName
46 Application.DisplayAlerts = True
47 End Sub
48 
49 Function SheetIsExist(shtName) As Boolean
50     Dim ws As Worksheet
51     On Error Resume Next
52     Set ws = Worksheets("" & shtName)
53     SheetIsExist = (Err = 0)
54     Err.Clear: On Error GoTo 0
55 End Function
Sheet1：
Template：