【VBA研究】如何用split函数设置表头

iamlaosong文

在用Excel的VBA连接数据库查询数据时往往会针对不同的数据采用不同的表头，笨办法是一个一个的给单元格赋值，这种办法在列数增加到几十个时就是恶梦了。聪明的办法是是将表头名称用空格（或其他符号）隔离后串在一起，然后赋给一个变量，再用split函数分离成一个数组，最后再用这个数组给单元格赋值，代码如下：

Sub tt()
    Dim aa() As String
    
    aa = Split("aa1 bb2 cc3 dd4 ee5 ff6 gg7 hh8 ii9", " ")
    Sheets("系统参数").Range("a11:i11") = aa
    Sheets("系统参数").Cells(12, 1).Resize(1, UBound(aa) + 1) = aa
End Sub

其中给表头赋值语句有两种表示方法，无论Sheets("系统参数")是不是当前工作表都没有问题。Range("a11:i11")这种表示方法中的列是字母，不方便用变量，所以我曾经想用range(cells(12,1),cells(12,9))这种表示方法，这种表示方法中的9很容易换成变量，但这种表示方法对活动工作表可以，非活动工作表则报错，即：

Sheets("系统参数").Range(Cells(12, 1),Cells(12, UBound(aa) + 1)) = aa

上面的表示方法当Sheets("系统参数")为活动工作表时不出错，因为是活动工作表，这个前缀也可以去掉。非活动工作表则会报错，即使把上面的变量换成常量也不行，所以，我后来采用上面那个Resize的办法。

还有一种赋值方法就是用循环的方法将数组赋给单元格，这是最容易想到的办法，如下面的代码所示：

            arr_head = Split(tbhead, " ")    '下标从0开始
            For k = 0 To UBound(arr_head)
                Sheets(name).Cells(1, k + 1) = arr_head(k)
            Next k

其中变量tbhead保存是空格分隔的表头。下面是完整代码：

'读取数据程序
Public Sub get_data()
    '根据工作表中的查询语句读取数据
    On Error GoTo ErrMsg:
    
    Dim cnn As Object, rst As Object
    Dim name, stat, sqls, field As String
    Dim pn(4), pm(4) As String
    Dim i, j, kk, pmkk, lineno, recno As Integer
    Dim OraOpen As Boolean
    
    time1 = Timer
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    sqls = "connect database"
    cnn.Open "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"
    OraOpen = True '成功执行后，数据库即被打开
    
    If OraOpen Then lineno = [D65536].End(xlUp).Row Else lineno = 0       '行数
    recno = 0
    
    Application.Calculation = xlManual
    For i = 3 To lineno
        stat = Trim(Cells(i, 3))
        
        If stat = "Y" Or stat = "y" Then
            recno = recno + 1
            name = Cells(i, 2)
            field = Cells(i, 4)
            pn(1) = Cells(i, 5)
            pm(1) = Cells(i, 6)
            pn(2) = Cells(i, 7)
            pm(2) = Cells(i, 8)
            pn(3) = Cells(i, 9)
            pm(3) = Cells(i, 10)
            pn(4) = Cells(i, 11)
            pm(4) = Cells(i, 12)
            pmkk = Cells(i, 13)
            sqls = Cells(i, 15)
            If Len(sqls) = 0 Then
                MsgBox "本行查询语句为空：" & i, vbCritical, "操作失败 ，请检查！"
                Exit Sub
            End If
            'MsgBox sqls
            Select Case pm(3)
                Case "航空"
                    tbname = "emsapp_js_hk_syf"
                    cljds = "pyjds"
                    tbhead = "结算日期 邮路代码 邮路名称 路单流水号 总包条码 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 "
                    tbhead = tbhead & "邮路级别 邮路种类 发出站代码 发出站 接收站代码 接收站 原寄局代码 原寄局 寄达局代码 寄达局 "
                    tbhead = tbhead & "结算属性 种类属性 航班编号 里程 计费重量 稽核重量 "
                    tbhead = tbhead & "派押局省份代码 派押局省份 派押局地市代码 派押局地市 派押局县市代码 派押局县市 派押局代码 派押局 派押局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 费率 费用 备注"
                Case "陆运"
                    tbname = "emsapp_js_ly_syf"
                    cljds = "pyjds"
                    tbhead = "结算日期 邮路代码 邮路名称 路单流水号 总包条码 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 "
                    tbhead = tbhead & "邮路级别 邮路种类 发出站代码 发出站 接收站代码 接收站 原寄局代码 原寄局 寄达局代码 寄达局 "
                    tbhead = tbhead & "结算属性 种类属性 航班编号 里程 计费重量 稽核重量 "
                    tbhead = tbhead & "派押局省份代码 派押局省份 派押局地市代码 派押局地市 派押局县市代码 派押局县市 派押局代码 派押局 派押局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 费率 费用 备注"
                Case "转运"
                    tbname = "emsapp_js_zy_syf"
                    cljds = "cljds"
                    tbhead = "结算日期 总包条码 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 寄达省 结算属性 种类属性 计费重量 稽核重量 "
                    tbhead = tbhead & "处理局省份代码 处理局省份 处理局地市代码 处理局地市 收寄局县市代码 处理局县市 收寄局代码 处理局 处理局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 费率 费用 备注"
                Case "投递"
                    tbname = "emsapp_js_td_syf"
                    cljds = "tdjds"
                    tbhead = "结算日期 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 结算属性 偏远地区 是否妥投 计费重量 稽核重量 "
                    tbhead = tbhead & "投递局省份代码 投递局省份 投递局地市代码 投递局地市 投递局县市代码 投递局县市 投递局代码 投递局 投递局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 首重费率 续重费率 费用 备注"
                Case "出口分拣"
                    tbname = "emsapp_js_ck_syf"
                    cljds = "cljds"
                    tbhead = "结算日期 总包条码 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 寄达省 结算属性 种类属性 计费重量 稽核重量 "
                    tbhead = tbhead & "处理局省份代码 处理局省份 处理局地市代码 处理局地市 处理局县市 处理局 处理局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 费率 费用 备注"
                Case "进口分拣"
                    tbname = "emsapp_js_jk_syf"
                    cljds = "cljds"
                    tbhead = "结算日期 总包条码 邮件条码 邮件种类编号 邮件种类名称 总包种类 总包种类名称 寄达省 结算属性 种类属性 计费重量 稽核重量 "
                    tbhead = tbhead & "处理局省份代码 处理局省份 处理局地市代码 处理局地市 处理局县市 处理局 处理局归属 "
                    tbhead = tbhead & "收寄局省份代码 收寄局省份 收寄局地市代码 收寄局地市 收寄局县市代码 收寄局县市 收寄局代码 收寄局 收寄局归属 "
                    tbhead = tbhead & "异常信息 费率 费用 备注"
                Case Else
                    MsgBox "错误明细选项：" & pn(3), vbCritical, "，请检查！"
                    Exit Sub
            End Select
                    
            sqls = Replace(sqls, "tbname", tbname, 1, 1)
            If name = "机构SYF" Then
                If pm(4) <> "" Then sqls = sqls & " and sjjdm like '" & pm(4) & "%'"
            ElseIf name = "邮路SYF" Then
                If pm(3) = "航空" Or pm(3) = "陆运" Then
                    If pm(4) <> "" Then sqls = sqls & " and yldm like '" & pm(4) & "%'"
                End If
            ElseIf name = "明细BCF" Then
                sqls = Replace(sqls, "syf", "bcf", 1, 1)
                If pm(4) <> "" Then sqls = sqls & " and " & cljds & " like '" & pm(4) & "%'"
            End If
            sqls = Replace(sqls, "?", pm(1), 1, 1)
            sqls = Replace(sqls, "?", pm(2), 1, 1)
            'Debug.Print sqls
            Set rst = cnn.Execute(sqls)
            sqls = "CopyFromRecordset"
            If Sheets(name).AutoFilterMode = True Then Sheets(name).Range("A1").AutoFilter
            maxrow = Sheets(name).UsedRange.Rows.Count
            Sheets(name).Range("a1:" & field & maxrow).ClearContents
            arr_head = Split(tbhead, " ")    '下标从0开始
            Sheets(name).Cells(1, 1).Resize(1, UBound(arr_head) + 1) = arr_head(k)
            Sheets(name).Range("a2").CopyFromRecordset rst
            Cells(i, 3) = "成功"
            Cells(i, 21) = Now()
            'MsgBox i
        End If
    Next i
    
    'rst.Close
    'Set rst = Nothing
    cnn.Close
    Set cnn = Nothing
    
    Application.Calculation = xlAutomatic
    'Sheets("分析").PivotTables("数据透视表1").PivotCache.Refresh
    Worksheets("系统参数").Select
    msg = MsgBox(recno & "个数据读取完毕，用时：" & Timer - time1 & "秒！", vbOKOnly, "iamlaosong")
    Exit Sub
ErrMsg:
    OraOpen = False
    MsgBox Err.Description, vbCritical, "操作失败 ，请检查！"
    MsgBox sqls, vbCritical, "错误语句"

End Sub