按模板生成工作表
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：
