VBA数据库中多表导出合并另存

'*****************************************************
'*                                                                   

'*数据库格式是*.accdb（2007版）

'* 数据库内各省份分别使用单独的表

'*将每个表中的数据导出到新工作表并保存

'*                                    Vincent   2010.12.01 

'*

'******************************************'**********

 

Dim sf As Variant
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim sql As String
Dim strsql As String
Dim savename As String
Dim backupfilename As String
sf = Array("安徽", "北京", "福建", "甘肃", "广东", "广西", "贵州", "海南", "河北","河南", "黑龙江", "湖北", "湖南", "吉林", "江苏", "江西", "辽宁", "内蒙古", "宁夏", "青海","山东", "山西", "陕西", "上海", "四川", "天津", "西藏", "新疆", "云南", "浙江","重庆")

cnn.Open"provider=microsoft.ace.oledb.12.0;data source=" &ThisWorkbook.Path & "\客户资料\data.accdb"& "; Jet OLEDB:DatabasePassword=password"

'创建新工作簿
Application.ScreenUpdating = False
'***添加新工作簿***
   Workbooks.Add
'***********************获取客户资料********************
'***联合语句***
For x = 0 To UBound(sf) '******遍历省份数组******
sql = "select * from " & sf(x) & "union " '******使用union联合各省份语句******
strsql = strsql & sql
Next x
'***清除最后一个union***
strsql = Left(strsql, Len(strsql) - 7)
Debug.Print strsql
'***打开数据库连接***
rst.Open strsql, cnn

'******操作活动工作簿******
With ActiveWorkbook
'***获取字段表头***
       For i = 0 To rst.Fields.Count - 1
           .Sheets("sheet1").Cells(1, i + 1) = rst.Fields(i).Name
       Next i
'***将数据复制到工作表上***
 .Sheets("sheet1").Range("A2").CopyFromRecordsetrst
'***工作表改名***
 .Sheets("sheet1").Name = "客户资料"
End With
strsql = ""
sql = ""
Set rst = Nothing

'***********************数据已全部获取完毕********************

backupfilename = Format(Now(),"yyyymmdd")
'******获取保存路径及文件名******
savename = ThisWorkbook.Path & "\数据库备份\"& backupfilename & "数据库备份"& ".xlsx"
'******另存工作簿并设置打开密码及只读密码******
ActiveWorkbook.SaveAs Filename:=savename, Password:="openpsw",writerespassword:="writepsw"
MsgBox "数据已全部导出成功！" & Chr(10) &Chr(10) & "保存路径是：" & Chr(10)& Chr(10) & savename, 64,"系统提示"
Application.ScreenUpdating = True

End Sub