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:Database
Password=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").CopyFromRecordset
rst

'***工作表改名***

 .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