20170727xlVBA根据数据表和模板工作簿生成个人明细表工作簿

Sub CreateTables()

    Dim Wb As Workbook

    Dim OpenWb As Workbook

    Dim Sht As Worksheet

    Dim Rng As Range

    Dim Arr As Variant

    Dim i As Long

    Const HEAD_ROW As Long = 2

    Dim EndRow As Long

    '模板文件名和路径

    Const ModelName As String = "社+名.xlsx"

    Dim ModelPath As String

    '生成文件名和路径

    Dim NewName As String

    Dim NewPath As String

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.Worksheets("明细表")

    ModelPath = Wb.Path & "\模板\" & ModelName    '社+名的完整路径

    With Sht

        EndRow = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row

        '内置方法，返回A列最后一个非空单元格行号

        Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, "I"))

        '引用区域，左上角单元格，右下角单元格，这样就获取数据区域了 自己领悟一下就知道了

        Arr = Rng.Value

        '存在一个数组里面，这样速度好很多

        '和单元格区域是一样的。只是它只有数据，没有框框颜色字体什么的，所以用起来很快

        Set OpenWb = Application.Workbooks.Open(ModelPath)

        '打开模板文件

        For i = LBound(Arr) To UBound(Arr)    '从第一行到最后一行，逐行循环

            'arr相当于是一个有行列结构的数组，和单元格区域是一样的。Lbound可以取到开始行，Ubound可以取到结束行

            '开始构建新文件名

            NewName = Arr(i, 9) & "-" & Arr(i, 2) & ".xlsx"

            'i是可变的，9就是第I列 经办行，2就是第B列的客户名称,新文件名就弄好了

            NewPath = Wb.Path & "\生成\" & NewName

            '新文件名的完整路径 就构造好了

            '开始填表

            '这里就做两个示范，剩下的你自己填就知道了

            '第一个sheet

            OpenWb.Worksheets("（一）档案封皮").Range("B13").Value = Arr(i, 2)    '借款人

            OpenWb.Worksheets("（一）档案封皮").Range("A23").Value = Arr(i, 9)    '经办行

            OpenWb.Worksheets("（二）债务主体认定书").Range("B4").Value = Arr(i, 2)    '经办行

            OpenWb.Worksheets("（二）债务主体认定书").Range("B5").Value = "'" & Arr(i, 1)   '贷款号

           '注意注意注意   长数字 前面一定要加上  "'" &  ，这样防止后面三位数字变成 000

            '************剩下自己弄

            OpenWb.SaveCopyAs NewPath    '填完就另存副本

        Next i

        OpenWb.Close False    '关掉模板

    End With

    '释放对象，告诉内存，这些东东我不要了，不然一直占着内存

    Set Wb = Nothing

    Set OpenWb = Nothing

    Set Sht = Nothing

    Set Rng = Nothing

    Erase Arr    '擦除数组

End Sub