一键导出代码改善

最近我又改进了代码的编写方式,觉得像下面这样的代码看起来太累,维护性也不好.

关键代码改善

 '-------------------------------------------------------------------------------------
    '4.1.表头数据写入
    '-------------------------------------------------------------------------------------
    ctlnames = Array("TO_客户", "Adreess", "TEL", "FAX", "ATT", "交货日期", _
                    "FROM_始运港", "资料提供日期", "运抵国", "ISSUE_BY", _
                    "制单日期", "币别", "INVOICE_NO", "CUSTOMER_ORDER_NO", _
                    "调整原因", "调整金额", "含佣金", "价格方式", "运抵港口", _
                    "BILLER", "PAYMENT_TERMS", "LAST_SHIPPING_DATE", _
                    "SIZE_OF_CONTAINER", "备注")
    arr_rngs = Array("B1", "B2", "B3", "B4", "B5", "B6", "B7", "B8", "B9", _
                    "B10", "E1", "E2", "E3", "E4", "E5", "E6", "E7", "E8", _
                    "E9", "E10", "H1", "H2", "H3", "K1")
'    wkbbb.Worksheets(mbwsh_name).Range("B1") = Me.TO_客户
    For i = 0 To UBound(ctlnames)
        wkbbb.Worksheets(mbwsh_name).Range(arr_rngs(i)) = Me.Controls(ctlnames(i))
    Next i

    '写入形式发票明细
    wkb_OFFSET = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19)
    wkbbb_OFFSET = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 20)
    For i = 0 To UBound(wkb_OFFSET)
        rng.OFFSET(0, wkb_OFFSET(i)).Resize(used_row_count - 1, 1).copy
        rngbb.OFFSET(0, wkbbb_OFFSET(i)).pastespecial xlpastevalues
    Next i

完整代码

Private Sub btn_记录导出_Click()
    '检查步骤变量
    Dim rsc1 As Integer
    Dim strSQL As String
    '-------------------------------------------------------------------------------------
    '检查及步骤
    '-------------------------------------------------------------------------------------
    rsc1 = DCount("*", "TMP_U_PROFORMA_Entry")
    If rsc1 = 0 Then
        MsgBox "订单明细为空,请完善订单之后再导出订单数据"
        Exit Sub
    End If

    DoCmd.SetWarnings False
    strSQL = "update TMP_U_PROFORMA_Entry set 净值=(1-折扣率)*[Unit_Price]"
    DoCmd.RunSQL strSQL
    strSQL = "update TMP_U_PROFORMA_Entry set TOTAL=(1-[折扣率])*[Unit_Price]*[QTY]"
    DoCmd.RunSQL strSQL
    strSQL = "update TMP_U_PROFORMA_Entry set 折扣额=[折扣率]*[Unit_Price]*[QTY]"
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    '一步骤变量
    Dim bbpath As String
    Dim mbwsh_name As String
    Dim mb_path As String
    Dim file_type As String
    Dim wkb As Object
    '二步骤的变量
    Dim ord_path As String
    Dim fname As String
    Dim Folder As String
    Dim tbl_name As String
    Dim EXL As Object
    '三步骤的变量
    Dim wkbbb As Object
    Dim rng As Object
    Dim rngbb As Object
    Dim used_row_count As Long
    '4.1步骤的变量
    Dim ctlnames As Variant
    Dim arr_rngs As Variant
    Dim ctlname As String
    Dim i As Integer
    Dim wkb_OFFSET As Variant
    Dim wkbbb_OFFSET As Variant



    '-------------------------------------------------------------------------------------
    '一.准备模板表格
    '-------------------------------------------------------------------------------------
    '复制模板表格到本文件夹下
    bbpath = CurrentProject.PATH & "\报表"
    mbwsh_name = "形式发票导入格式"
    mb_path = "\\192.168.7.19\更新文件\报表模板"
    file_type = ".xlsx"
    copyFile bbpath, mb_path, mbwsh_name, file_type

    '模板表格不着急打开,等所有准备好了再打开


    '-------------------------------------------------------------------------------------
    '二.输出数据库数据表例如PQ分析(没有汇总的结果)到Excel中间表
    '-------------------------------------------------------------------------------------
    tbl_name = "TMP_U_PROFORMA_Entry" '数据库中等待导出的原始表格,这里面存放着我的PQ分析底层数据
    fname = "表格导出" '那么PQ分析导出到哪里呢?导入到"表格导出.xlsx"
    Folder = "Excel输出文件夹"
    ord_path = CurrentProject.PATH & "\" & Folder & "\" & fname & ".xlsx" '这个表示最后的表格输出到"Excel输出文件夹\表格导出.xlsx"中中
    '上线都是在准备ExportToExcelQueryTables的3个传入参数.
    'ExportToExcelQueryTables的作用是复制表格到一个中间文件夹里面.

    ExportToExcelQueryTables tbl_name, Folder, fname



    If Len(Dir(ord_path, vbDirectory)) > 0 Then
'        On Error GoTo 创建:
        'MsgBox "文件" & CurrentProject.Path & "\报表\" & fileName & "已经存在"
'        Set EXL = GetObject(, "Excel.Application")
        Set EXL = CreateObject("Excel.Application")
        'Set xlWbk = xlApp.Workbooks.Open(CurrentProject.Path & "\报表\" & wshName)
        Set wkb = EXL.Workbooks.Open(ord_path)
        EXL.Visible = False
        EXL.Visible = True
    Else
        MsgBox "订单不存在,请生成后再打开"
    End If


    '-------------------------------------------------------------------------------------
    '三.打开等待输入数据的报表,需要用的东西都要准备好
    '-------------------------------------------------------------------------------------
    '打开等待输入数据的报表,wkbbb的含义是workbookBaobiao=报表工作簿,这个还是只是工作簿注意
    'wkbbb这个可以直接在里面写东西,例如:wkbbb.Worksheets(mbwsh_name).Range("F4") = Me.年份 & "年"
    Set wkbbb = EXL.Workbooks.Open(bbpath & "\" & mbwsh_name & file_type)
    Set rng = wkb.Worksheets(tbl_name).Range("a2")
    Set rngbb = wkbbb.Worksheets(mbwsh_name).Range("A13")
    '记录戒指行数
    used_row_count = wkb.Worksheets(tbl_name).UsedRange.rows.Count
    '-------------------------------------------------------------------------------------
    '四.数据交互
    '-------------------------------------------------------------------------------------
    '4.1.表头数据写入
    '-------------------------------------------------------------------------------------
    ctlnames = Array("TO_客户", "Adreess", "TEL", "FAX", "ATT", "交货日期", _
                    "FROM_始运港", "资料提供日期", "运抵国", "ISSUE_BY", _
                    "制单日期", "币别", "INVOICE_NO", "CUSTOMER_ORDER_NO", _
                    "调整原因", "调整金额", "含佣金", "价格方式", "运抵港口", _
                    "BILLER", "PAYMENT_TERMS", "LAST_SHIPPING_DATE", _
                    "SIZE_OF_CONTAINER", "备注")
    arr_rngs = Array("B1", "B2", "B3", "B4", "B5", "B6", "B7", "B8", "B9", _
                    "B10", "E1", "E2", "E3", "E4", "E5", "E6", "E7", "E8", _
                    "E9", "E10", "H1", "H2", "H3", "K1")
'    wkbbb.Worksheets(mbwsh_name).Range("B1") = Me.TO_客户
    For i = 0 To UBound(ctlnames)
        wkbbb.Worksheets(mbwsh_name).Range(arr_rngs(i)) = Me.Controls(ctlnames(i))
    Next i

    '写入形式发票明细
    wkb_OFFSET = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19)
    wkbbb_OFFSET = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 20)
    For i = 0 To UBound(wkb_OFFSET)
        rng.OFFSET(0, wkb_OFFSET(i)).Resize(used_row_count - 1, 1).copy
        rngbb.OFFSET(0, wkbbb_OFFSET(i)).pastespecial xlpastevalues
    Next i
End Sub