如何使用 VBA 和 SQL 从其他 Excel 检索数据？

Question

我的代码有问题。 我尝试从其他 Excel 文件中检索数据。 我的代码有效，但我在一个单元格 (A1) 中收到了完整数据。 对不起，我只是初学者，相信这是与输出相关的问题，但我不知道为什么：

Sub RefreshData()

'Refresh data

Dim CreateNew As Object
Dim RunSELECT As Object
Dim Data As String
Dim SQL As String

FolderPath = ActiveWorkbook.path

path = Left(FolderPath, InStrRev(FolderPath, "\") - 1)

Set CreateNew = CreateObject("ADODB.Connection")
With CreateNew
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & path & "\Task1.xlsm; Extended Properties=Excel 12.0 Xml;HDR=YES;IMEX=1;CorruptLoad=xlRepairFile"
    .Open
End With

'Run SQL

SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
Do
   output = output & RunSELECT(0) & ";" & RunSELECT(1) & ";" & RunSELECT(2) & vbNewLine
   Debug.Print RunSELECT(0); ";" & RunSELECT(1) & ";" & RunSELECT(2)
   RunSELECT.Movenext
Loop Until RunSELECT.EOF

ThisWorkbook.Worksheets("Dic").Range("A1").Value = output

    RunSELECT.Close
    CreateNew.Close
    Set CreateNew = Nothing
    Set RunSELECT = Nothing

End Sub

Answer 1

无需使用Do循环用分号分隔符包装记录集值。 只需使用Range.CopyFromRecordset ：

SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)

ThisWorkbook.Worksheets("Dic").Range("A1").CopyFromRecordset RunSELECT

RunSELECT.Close
CreateNew.Close

Set CreateNew = Nothing
Set RunSELECT = Nothing

Answer 2

ADOdb 从另一个工作簿中检索数据（无需打开它）

• 在copySheetADOdb结合一些帖子的 Parfait 解决方案时，我想出了函数copySheetADOdb 。
• 调整testCopySheetADOdb Source和Target下的常量进行测试。

编码

Option Explicit

Sub testCopySheetADOdb()
    
    ' Initialize error handling.
    Const ProcName = "testCopySheetADOdb"
    On Error GoTo clearError ' Turn on error trapping.
    
    ' Source
    Const Path As String = "F:\Test"
    Const FileName As String = "Test.xlsx"
    ' Sheet Name ('SheetName') is case-insensitive i.e. 'A = a'.
    Const SheetName As String = "Sheet1"
    
    ' Target
    Const tgtName As String = "Sheet1"
    Const tgtCell As String = "A1"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define FilePath.
    Dim FilePath As String
    FilePath = Path & Application.PathSeparator & FileName
    
    ' Define Target Range.
    Dim rng As Range
    Set rng = wb.Worksheets(tgtName).Range(tgtCell)
    
    ' Test Result.
    Dim Result As Boolean
    Result = copySheetADODb(rng, FilePath, SheetName)
    
    ' Of course you can do all the above in one line:
    'Result = copySheetADODB(Thisworkbook.Worksheets("Sheet1").Range("A1"), _
                            "C:\Test\Test.xlsx", "Sheet1")
    
    ' Inform user.
    If Result Then
        MsgBox "Worksheet successfully copied.", vbInformation, "Success"
    Else
        MsgBox "Worksheet not copied.", vbExclamation, "Failure"
    End If
        
ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "':" & vbLf & "    " & "Run-time error '" _
              & Err.Number & "':" & vbLf & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Sub

Function copySheetADOdb(TargetCellRange As Range, _
                        ByVal SourceFilePath As String, _
                        Optional ByVal SourceSheetName As String = "Sheet1") _
         As Boolean
    
    ' Initialize error handling.
    Const ProcName = "copySheetADOdb"
    On Error GoTo clearError ' Turn on error trapping.
    
    ' Test Target Cell Range ('TargetCellRange').
    If TargetCellRange Is Nothing Then
        GoTo NoTargetCellRange
    End If
    If TargetCellRange.Rows.Count > 1 Or TargetCellRange.Columns.Count > 1 Then
        GoTo OneCellOnly
    End If
'
    ' Define SQL Generic String.
    Const sqlGeneric As String = "SELECT * FROM [SheetName$]"
    
    Dim conn As Object
    Set conn = CreateObject("ADODB.Connection")
    Dim strErr As String
    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        ' If you need the headers, HDR=NO means there are no headers
        ' (not: do not retrieve headers) so the complete data will be retrieved.
        .ConnectionString = "Data Source='" _
                          & SourceFilePath _
                          & "';" _
                          & "Extended Properties='" _
                          & "Excel 12.0 Xml;" _
                          & "HDR=NO;" _
                          & "IMEX=1;" _
                          & "CorruptLoad=xlRepairFile" _
                          & "';"
        On Error GoTo connOpenError
        .Open
            On Error GoTo clearError
            ' Run SQL.
            Dim SQL As String
            ' Replace 'SheetName' in SQL Generic String
            ' with the actual sheet name ('SourceSheetName').
            SQL = Replace(sqlGeneric, "SheetName", SourceSheetName)
            Dim rs As Object
            On Error GoTo connExecuteError
            Set rs = .Execute(SQL)
            On Error GoTo clearError
            If Not TargetCellRange Is Nothing Then
                ' Copy sheet.
                If Not rs.EOF Then
                    TargetCellRange.CopyFromRecordset rs
                    ' Write result.
                    copySheetADOdb = True
                Else
                    GoTo NoRecords
                End If
            End If
NoRecordsExit:
            rs.Close
connExecuteExit:
        .Close
    End With
    
ProcExit:
    Set rs = Nothing
    
connOpenExit:
    Set conn = Nothing

    Exit Function

NoTargetCellRange:
    Debug.Print "'" & ProcName & "': " & "No Target Cell Range ('Nothing')."
    GoTo ProcExit
    
OneCellOnly:
    Debug.Print "'" & ProcName & "': " _
              & "Target Cell Range has to be one cell range only."
    GoTo ProcExit

NoRecords:
    Debug.Print "'" & ProcName & "': No records found."
    GoTo NoRecordsExit

connOpenError:
    If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
        strErr = "'" & SourceFilePath & "' is not a valid path"
        If Left(Err.Description, Len(strErr)) = strErr Then
            Debug.Print "'" & ProcName & "': " & strErr & "..."
            On Error GoTo 0 ' Turn off error trapping.
            GoTo connOpenExit
        End If
    Else
        GoTo clearError
    End If

connExecuteError:
    If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
        strErr = "'" & SourceSheetName & "' is not a valid name"
        If Left(Err.Description, Len(strErr)) = strErr Then
            Debug.Print "'" & ProcName & "': " & strErr & "..."
            On Error GoTo 0 ' Turn off error trapping.
            GoTo connExecuteExit
        End If
    Else
        GoTo clearError
    End If

clearError:
    Debug.Print "'" & ProcName & "':" & vbLf & "    " & "Run-time error '" _
              & Err.Number & "':" & vbLf & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Function

Answer 3

您在此代码中遇到问题：

ThisWorkbook.Worksheets("Dic").Range("A1").Value = output

您自己要求将输出保存到 A1 单元格。

我建议您根据需要使用 for 或 while 循环在单元格中输入数据。