【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