使用 ADODB 从关闭的工作簿导入

Question

在该领域工作了这么多小时后，我可以从已关闭的工作簿中的所有工作表中获取数据，并且可以使用 ADODB 从特定列中获取数据。 @Siddharth Rout 帮助我能够按制表符的顺序获取工作表名称。 以下代码仅适用于一个已关闭的工作簿。但实际上我正在尝试做同样的事情并从几个工作簿中获取特定列（参考 - 参考号 - 编号 ..）中的所有数据

Sub ImportFromClosedWorkbook()
    Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
    sFile = ThisWorkbook.Path & "\Sample.xlsx"
    Dim con As Object
    Set con = CreateObject("DAO.DBEngine.120")
    Dim rsData As ADODB.Recordset
    Set cn = New ADODB.Connection
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set ws = ThisWorkbook.ActiveSheet
    Dim db As Object, i As Long
    Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
    For i = 0 To db.TableDefs.Count - 1
        sName = db.TableDefs(i).Name
        b = False
        strSQL = "SELECT * FROM [" & sName & "]"
        Set rsHeaders = New ADODB.Recordset
        rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
        For iCol = 0 To rsHeaders.Fields.Count - 1
            For Each e In Array("Ref No", "Reference", "Number")
                If e = rsHeaders.Fields(iCol).Name Then
                    b = True: Exit For
                End If
            Next e
            If b Then Exit For
        Next iCol
        If b Then
            strSQL = "SELECT [" & e & "] FROM [" & sName & "]"
            Set rsData = New ADODB.Recordset
            Set rsData = cn.Execute(strSQL)
            ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
            rsData.Close
        End If
    Next i
    db.Close: Set db = Nothing
    Set con = Nothing
    cn.Close: Set cn = Nothing
End Sub

是否适合构建公共程序或在这种情况下最好的方法是什么？如何以正确的方式释放对象？

Answer 1

我会进一步分解您的代码 - 可以将不同的活动分解为可重用的方法。

仅供参考，您的 tableDefs 对象已包含字段名称，因此无需单独查询这些名称。

例如：

Sub ImportFromClosedWorkbook()
    Dim sFile As String, sheetName As String, colName As String, rs As ADODB.Recordset
    Dim cols As Collection, col
    
    sFile = ThisWorkbook.FullName
    
    Set cols = FindColumns(sFile, Array("Ref", "Reference", "RefNo"))
    'loop found columns
    For Each col In cols
        
        sheetName = col(0)
        colName = col(1)
        Debug.Print "##", sheetName, colName
        Set rs = WorkBookQuery(sFile, "Select [" & colName & "] from [" & sheetName & "]")
        If Not rs.EOF Then
         '   ActiveSheet.Cells(Rows.Count, "A").End(xlUp).CopyFromRecordset rs
        End If
    
    Next col

End Sub

'given a workbook path, find all column headings matching andname in arrNames
'returns a collections of [sheetName, columnName] arrays
Function FindColumns(wbFullPath As String, arrNames) As Collection
    
    Dim tabledefs As Object, td As Object, f As Object, rv As New Collection
    
    Set tabledefs = CreateObject("DAO.DBEngine.120") _
                     .OpenDatabase(wbFullPath, False, True, "Excel 12.0 XMl;").tabledefs
    
    For Each td In tabledefs
        For Each f In td.Fields
            'Debug.Print td.Name, f.Name
            If Not IsError(Application.Match(f.Name, arrNames, 0)) Then
                rv.Add Array(td.Name, f.Name)
            End If
        Next f
    Next td
    Set FindColumns = rv
End Function

'run a SQL query against a workbook
Function WorkBookQuery(wbFullPath As String, SQL As String) As ADODB.Recordset
    Dim rs As ADODB.Recordset
    With New ADODB.Connection
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & wbFullPath & "';" & _
               "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
        Set WorkBookQuery = .Execute(SQL, Options:=1)
    End With
End Function

Answer 2

在字段循环过程中似乎存在逻辑错误。最好使用一个用户定义的函数来检查字段名称是否存在。

Sub ImportFromClosedWorkbook()
    Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
    Dim sField As String
    
    sFile = ThisWorkbook.Path & "\Sample.xlsx"
    Dim con As Object
    Set con = CreateObject("DAO.DBEngine.120")
    Dim rsData As ADODB.Recordset
    Set cn = New ADODB.Connection
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set ws = ThisWorkbook.ActiveSheet
    Dim db As Object, i As Long
    Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
    For i = 0 To db.TableDefs.Count - 1
        sName = db.TableDefs(i).Name
        b = False
        strSQL = "SELECT * FROM [" & sName & "]"
        Set rsHeaders = New ADODB.Recordset
        rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
        
        For iCol = 0 To rsHeaders.Fields.Count - 1
'            For Each e In Array("Ref No", "Reference", "Number")
'                If e = rsHeaders.Fields(iCol).Name Then
'                    b = True: Exit For
'                End If
'            Next e
'            If b Then Exit For
'        Next iCol
'        If b Then
            sField = rsHeaders.Fields(iCol).Name
            If isField(sField) Then
                strSQL = "SELECT [" & sField & "] FROM [" & sName & "]"
                Set rsData = New ADODB.Recordset
                Set rsData = cn.Execute(strSQL)
                ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
                rsData.Close
            End If
        Next iCol
    Next i
    db.Close: Set db = Nothing
    Set con = Nothing
    cn.Close: Set cn = Nothing
End Sub
Function isField(sField As String) As Boolean
    Dim vName As Variant, e As Variant
    vName = Array("Ref No", "Reference", "Number")
    For Each e In vName
        If e = sField Then
            isField = True
            Exit Function
        End If
    Next e
End Function

Answer 3

如果所有文件都具有相同的结构并且在一个文件夹中，您可以使用 FileSystemObject 引用，如下所示：

“https://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba”

您可以在文件系统代码中循环运行现有代码，希望有效