Excel VBA ADO 循环

Question

我的问题可能很简单，但我找不到合适的解决方案。

我有几个 Excel 电子表格，在第一个电子表格中，我用唯一的 6 位数 ID 填充了 A 列

然后，使用 ADO 连接，我需要从第二个电子表格（包含大量数据）中获取与这些唯一 ID 对应的信息

到目前为止，我实现了下面的代码，但我很确定这不是最好或最快的方法（因为它非常慢）

当然，我有一个 VBA 例程，它可以在没有 ADO 的情况下执行此操作，但信息量越来越大，很快就会成为问题。

希望ADO能帮我管理一下，谢谢

Sub UpdateCurrentStatus()
    Dim sSQLQry As String
    Dim ReturnArray
    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset
    Dim DBPath As String, sconnect As String
    Dim UID As String


    If MsgBox("Is the Labinal extract up-to-date?", vbYesNo) = vbNo Then Exit Sub

    Application.ScreenUpdating = False

    DBPath = Application.GetOpenFilename(Title:="Select second spreadsheet", FileFilter:="CSV (Comma delimited) (*.csv), *.csv")

    sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';FMT=Delimited(;)"
    Conn.Open sconnect

    y = 2
    Do
        UID = ThisWorkbook.Worksheets("Sheet1").Cells(y, 1).Value

        sSQLSting = "SELECT [CurrentPhase] From [LabinalExtract$] where TicketReference =" & UID ' Your SQL Statement (Table Name= Sheet Name=[Sheet1$])"

        mrs.Open sSQLSting, Conn

        Sheets(1).Range("B2").CopyFromRecordset mrs

        mrs.Close

         y = y + 1

    Loop While ThisWorkbook.Worksheets("Sheet1").Cells(y, 1) <> ""

    Conn.Close

End Sub

Answer 1

考虑避免任何循环，只需在 SQL 中连接两个工作簿，因为 Windows 的 Jet/ACE 引擎允许对 Excel 工作簿、Access 数据库甚至文本文件进行内联查询。

下面假设您在唯一 ID 的主工作簿中的列标题在名为 Sheet1 的工作表中命名为 Column1（如果不是，请更改 SQL 的 SELECT 和 ON 子句）。此外，不清楚您是连接到 CSV 文件还是 Excel 工作簿。这假定两者都是 Excel 工作簿。

' CURRENT WORKBOOK CONNECTION (LAST SAVED STATE)
xlConn.Open "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
              & "DBQ=" & ThisWorkbook.FullName & ";"

' JOIN QUERY WITH INLINE EXTERNAL CONNECTION
sSQLSting = "SELECT t1.Column1, t2.[CurrentPhase]" _
               & " FROM [Sheet1$] t1" _
               & " INNER JOIN" _
               & "     (SELECT * FROM" _
               & "     [Excel 12.0 Xml;HDR=Yes;Database=" & DBPath & "].[LabinalExtract$]) t2" _
               & " ON t1.Column1 = t2.TicketReference"

' OUTPUT QUERY RESULTS
mrs.Open sSQLSting, xlConn

Sheets(1).Range("B2").CopyFromRecordset mrs

mrs.Close
xlConn.Close

Answer 2

我成功地改编了 Parfait 提供的代码，现在正在运行，希望它可以帮助其他人

小心行中：

& "     [Excel 12.0 Xml;HDR=Yes;Database=" & DBPath & "].[Labinal]) t2" _

[Labinal] 指 Excel 中的命名范围（表格）

第二行：

sSQLSting = "SELECT t2.[CurrentPhase]" _

您选择要返回的数据，在这种情况下，我将其简化为我用作数据库的 Excel 文件中名为“当前阶段”的列（包含在范围名称中为“Labinal”）

这里是最终代码：

Sub UpdateCurrentStatus()
    Dim sSQLQry, sSQLSting As String
    Dim ReturnArray
    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset
    Dim DBPath As String, sconnect As String

    If MsgBox("Is the Labinal extract up-to-date?", vbYesNo) = vbNo Then Exit Sub

    'Application.ScreenUpdating = False

    DBPath = Application.GetOpenFilename(Title:="Selecciona el extracto de iMade", FileFilter:="Excel files (*.xlsx), *.xlsx")


    ' CURRENT WORKBOOK CONNECTION (LAST SAVED STATE)
    Conn.Open "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm,    *.xlsb)};" _
              & "DBQ=" & ThisWorkbook.FullName & ";"

    ' JOIN QUERY WITH INLINE EXTERNAL CONNECTION
    sSQLSting = "SELECT t2.[CurrentPhase]" _
               & " FROM [Sheet1$] t1" _
               & " INNER JOIN" _
               & "     (SELECT * FROM" _
               & "     [Excel 12.0 Xml;HDR=Yes;Database=" & DBPath & "].[Labinal]) t2" _
               & " ON t1.Column1 = t2.TicketReference"

    ' OUTPUT QUERY RESULTS
    mrs.Open sSQLSting, Conn

    Sheets(1).Range("B2").CopyFromRecordset mrs

mrs.Close
Conn.Close


End Sub

Answer 3

试试这样。使用子程序。

Sub myQuery()
Dim y As Integer
y = 2
Do
     UID = ThisWorkbook.Worksheets("Sheet1").Cells(y, 1).Value

    sSQLSting = "SELECT [CurrentPhase] From [LabinalExtract$] where TicketReference =" & UID ' Your SQL Statement (Table Name= Sheet Name=[Sheet1$])"
     y = y + 1

Loop While ThisWorkbook.Worksheets("Sheet1").Cells(y, 1) <> ""

End Sub
Sub UpdateCurrentStatus(sSQLQry As String)
'Dim sSQLQry As String
Dim ReturnArray
Dim Conn As New ADODB.Connection
Dim mrs As New ADODB.Recordset
Dim DBPath As String, sconnect As String
Dim UID As String


If MsgBox("Is the Labinal extract up-to-date?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False


DBPath = Application.GetOpenFilename(Title:="Select second spreadsheet", FileFilter:="CSV (Comma delimited) (*.csv), *.csv")

sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';FMT=Delimited(;)"
Conn.Open sconnect

    mrs.Open sSQLSting, Conn

    Sheets(1).Range("B" & Rows.Count).End(xlUp)(2).CopyFromRecordset mrs

    mrs.Close

    Set mrs = Nothing
Conn.Close

End Sub