请教一个批量导出多个mdb中特定表至excel的问题

wanderary

需要将几百个 mdb 中的特定的一张表（假定为 sel ）导出到 excel，最好是以原 mdb 的文件名作为工作簿名分别保存

不会vba……搜索也没发现类似的应用

access 那边完全抓瞎，只会右键导出……

excel 这边有也数据导入的功能录成了宏也不知如何修改成批量导出

求达人指点，谢谢

zhaogang1960

问题似乎不太难，请模拟效果上传附件

wanderary

谢谢z大

模拟了一个简单的情况附件

目标是想把 dir 文件夹下的所有 mdb （附件里就做了两个） 中的 x 表分别导出到 dir 文件夹下的同名 xlsx 中

运行在 dir 文件夹下的 vba工作簿 后，在 dir 文件夹下生成 database1.xlsx 和 database2.xlsx，里面都只有对应的 x 表的内容

这样不知道表述清楚了没有

再次感谢

zhaogang1960

wanderary 发表于 2016-3-31 12:06
谢谢z大

模拟了一个简单的情况附件

不好意思，下午有事儿刚回来
请参考：
Sub 批量生成工作簿()
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim rst As ADODB.Recordset
    Dim Fso As New FileSystemObject
    Dim oFile As File
    Dim SQL$, p$, sFile$, wb As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\"
    For Each oFile In Fso.GetFolder(p).Files
        If oFile.Name Like "*.accdb" Then
            Set cnn = New ADODB.Connection
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & oFile
            Set rs = cnn.OpenSchema(adSchemaTables)
            n = 0
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    n = n + 1
                    s = rs("TABLE_NAME").Value
                    Set rst = New ADODB.Recordset
                    SQL = "select * from " & s
                    rst.Open SQL, cnn, adOpenKeyset, adLockOptimistic
                    
                    If n = 1 Then
                        Set wb = Workbooks.Add(xlWBATWorksheet)
                    Else
                        wb.Sheets.Add After:=wb.Sheets(n - 1)
                    End If
                    wb.Sheets(n).Name = s
                    For i = 1 To rst.Fields.Count
                        wb.ActiveSheet.Cells(1, i) = rst.Fields(i - 1).Name
                    Next
                    wb.ActiveSheet.Range("A2").CopyFromRecordset rst
                End If
                rs.MoveNext
            Loop
            wb.SaveAs Replace(oFile, "accdb", ".xlsx")
            wb.Close
        End If
        
    Next
    rs.Close
    rst.Close
    cnn.Close
    Set rs = Nothing
    Set rst = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

zhaogang1960

请测试附件
dir.rar (56.16 KB, 下载次数: 120)

2016-3-31 17:19 上传

点击文件名下载附件

zhaogang1960

上面使用常规法生成工作簿，下面代码使用ADO直接生成工作簿，但有个小问题，如果工作表名为c 或 r时，打开工作簿时会提示有错误，下面代码遇到c 或 r时后面加上一个“表”：
Sub ADO直接生成工作簿()
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim Fso As New FileSystemObject
    Dim oFile As File
    Dim myTable As String
    Dim myPath As String
    Dim SQL$, n&, sh$
    For Each oFile In Fso.GetFolder(ThisWorkbook.Path).Files
        If oFile.Name Like "*.accdb" Then
            Set cnn = New ADODB.Connection
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & oFile
            Set rs = cnn.OpenSchema(adSchemaTables)
            n = 0
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    n = n + 1
                    myTable = rs("TABLE_NAME").Value
                    If UCase(myTable) = "C" Or UCase(myTable) = "R" Then sh = myTable & "表" Else sh = myTable '打开ADO生成名为C或R的工作表时会提示有错，Excel2010可以纠错
                    myPath = Replace(oFile, "accdb", "xlsx")
                    If n = 1 Then If Dir(myPath) <> "" Then Kill myPath
                    SQL = "SELECT * INTO [Excel 12.0 xml;Database=" & myPath & ";]." & sh & " FROM " & myTable
                    cnn.Execute SQL
                End If
                rs.MoveNext
            Loop
        End If
    Next
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    MsgBox "ok"
End Sub

zhaogang1960

请测试附件
ADO直接生成工作簿.rar (56.2 KB, 下载次数: 95)

2016-3-31 18:37 上传

点击文件名下载附件

wanderary

zhaogang1960 发表于 2016-3-31 18:38
请测试附件

非常感谢z大

才发现我上传的附件格式是 accdb，但实际上碰到的都是 mdb（不熟悉 Access 犯的错……实在不好意思）

另外这个 xlsm 执行后直接提取出了所有的表，但因为我的每个 mdb 里面都有几十张表，所以我想指定特定的表，比方说在 xlsm 里或者 vba 代码里填入表的名称，然后执行后就导出这一张表到工作簿里，最终结果是每个工作簿里都只有一张工作表，附件里的就是 x

请问z大这两个问题如何修改

zhaogang1960

wanderary 发表于 2016-4-1 09:07
非常感谢z大

才发现我上传的附件格式是 accdb，但实际上碰到的都是 mdb（不熟悉 Access 犯的错……实 ...

Sub ADO直接生成工作簿() 'mdb
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim Fso As New FileSystemObject
    Dim oFile As File
    Dim myTable As String
    Dim Mypath As String
    Dim SQL$, n&, sh$
    myTable = InputBox("请输入导出数据表名")
    If myTable = "" Then Exit Sub
    For Each oFile In Fso.GetFolder(ThisWorkbook.Path).Files
        If oFile.Name Like "*.mdb" Then
            Mypath = Replace(oFile, "mdb", "xls")
            If Dir(Mypath) <> "" Then Kill Mypath
            Set cnn = New ADODB.Connection
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & oFile
            If cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, myTable, Empty)).EOF Then
                MsgBox myTable & "表" & "不存在，请重新输入。", vbInformation
                Exit For
            End If
            SQL = "SELECT * INTO [Excel 8.0;Database=" & Mypath & ";]." & myTable & " FROM " & myTable
            cnn.Execute SQL
        End If
    Next
    cnn.Close
    Set cnn = Nothing
    Set Fso = Nothing
    MsgBox "ok"
End Sub

zhaogang1960

请测试附件
dir2.rar (44.26 KB, 下载次数: 126)

2016-4-1 09:37 上传

点击文件名下载附件