'*****************************************************
'*
'* 数据库格式是*.accdb(2007版)
'* 数据库内各省份分别使用单独的表
'* 将每个表中的数据导出到新工作表并保存
'*
'*
'******************************************'**********
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
'***添加新工作簿***
'***********************获取客户资料********************
'***联合语句***
For x = 0 To UBound(sf)
sql = "select * from " & sf(x) & " union "
strsql = strsql & sql
Next x
'***清除最后一个union***
strsql = Left(strsql, Len(strsql) - 7)
Debug.Print strsql
'***打开数据库连接***
rst.Open strsql, cnn
'******操作活动工作簿******
With ActiveWorkbook
'***获取字段表头***
'***将数据复制到工作表上***
'***工作表改名***
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