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

  

posted @ 2017-07-27 17:36  wangway  阅读(743)  评论(0编辑  收藏  举报