对整个列执行一次查询，而不是遍历所有单元格

Question

我使用下面的循环遍历一列并对每个单元格值执行查询。鉴于此列中的单元格数量很容易超过 10'000 行，这不是一个非常快速的方法，因此我正在寻找另一种方法来提高性能。

我正在考虑用单元格的值填充一个数组，但是使用这种方法很可能仍然需要遍历所述数组并为每次迭代执行查询。

我不熟悉任何可能执行一次查询或至少显着提高此过程的性能的方法。有什么想法吗？

Public Function getdata(query As String) As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim connstring As String
Set cnn = New ADODB.Connection

connstring = "Provider=SQLOLEDB;Data Source=noneofyourbusiness;Connect Timeout=180"
cnn.Open connstring

Set getdata = New ADODB.Recordset
    getdata.CursorLocation = adUseClient
getdata.Open query, connstring, 2, adLockReadOnly
End Function

Sub start()
'code...

For Each c In sht.Range("J3:J" & LRow)
    If Not c.Value = "" Then
        'Query
        Set rs = getdata("SELECT 'Checked' FROM astAssetTypes AT JOIN astAssetTypesUDFV UDFV ON UDFV.TableLinkId = AT.Id WHERE UDFV.Userfield13Id = '5029' AND AT.Code = '" & c.Value & "'")
        If Not rs.EOF Then
            sht.Cells(c.Row, "L").CopyFromRecordset rs
            With sht.Range(sht.Cells(c.Row, "A"), sht.Cells(c.Row, LCol)).Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.349986266670736
            End With
            rs.Close
        End If
    End If
Next c

'code...
End Sub 

Answer 1

方法一。

如果您在 SQL 上有 dbo，则创建一个临时表并在那里加载 Excel 数据。使用高效的字符串构建方法一次性完成（即使用 Mid 替换而不是常量连接）。或者使用集成直接加载数据。运行查询并返回数据。找出需要格式化的单元格并立即执行（循环使用 Union 以获得一个大范围）。

方法二。

使用客户端游标，从 SQL 加载所有数据并使用 rs.Filter 查找匹配记录。您可以将 Excel 数据加载到数组或断开连接的记录集中，然后将其放回。

重要的是不要不必要地写回 Excel。写入 Excel 的次数不应超过两次。

类似（代码未完全测试）

Dim rsLocal As ADODB.Recordset ' create a local, disconnected recordset
Set rsLocal = New ADODB.Recordset
rsLocal.CursorLocation = adUseClient
rsLocal.Fields.Append "L", adVarChar, 1024, adFldIsNullable ' change to suit your data
rsLocal.Open

Dim myRange As Range

rs.CursorLocation = adUseClient
'bring all the records back into memory
Set rs = GetData("SELECT 'Checked', AT.Code Code FROM astAssetTypes AT JOIN astAssetTypesUDFV UDFV ON UDFV.TableLinkId = AT.Id WHERE UDFV.Userfield13Id = '5029' AND AT.Code = '")


For Each c In sht.Range("J3:J" & lrow)
    rsLocal.AddNew
    If c.Value <> "" Then
        rs.Filter = "Code='" & c.Value & "'" 'use Filter to prevent lots of round trips
        If rs.RecordCount <> 0 Then
            rs.MoveFirst
            rsLocal("L") = rs("Code")

            'add the cells to the range as we go
            If myRange Is Nothing Then
                Set myRange = sht.Range(sht.cells(c.Row, "A"), sht.cells(c.Row, LCol))
            Else
                Set myRange = Union(sht.Range(sht.cells(c.Row, "A"), sht.cells(c.Row, LCol)), myRange)
            End If
        End If
    End If
    rsLocal.Update
Next

rsLocal.MoveFirst
sht.Range("L3").CopyFromRecordset rsLocal 'write all updates at once

With myRange.Font ' do all formatting at once
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = -0.349986266670736
End With

Answer 2

Sub start()

    Dim strCodes$, rng1 As Range, rng2 As Range, cell As Range

    '// Generate "IN" clause
    For Each c In sht.Range("J3:J" & LRow)
        If Len(c) > 0 Then
            strCodes = strCodes & "'" & c & "'" & IIf(c.Row = LRow, "", ",")
        End If
    Next

    'Query
    Set rs = getdata( _
        "SELECT 'Checked', AT.Code FROM astAssetTypes AT JOIN astAssetTypesUDFV UDFV ON UDFV.TableLinkId = AT.Id " & _
        "WHERE UDFV.Userfield13Id = '5029' AND AT.Code IN (" & strCodes & ");")
    While Not rs.EOF
        Set cell = sht.Columns("J:J").Find(rs("Code"), LookAt:=xlWhole)
        If Not cell Is Nothing Then
            If rng1 Is Nothing Then
                Set rng1 = sht.Cells(cell.Row, "L")
            Else
                Set rng1 = Union(rng1, sht.Cells(cell.Row, "L"))
            End If
            If rng2 Is Nothing Then
                Set rng2 = sht.Cells(cell.Row, "A").Resize(, LCol)
            Else
                Set rng2 = Union(rng2, sht.Cells(cell.Row, "A").Resize(, LCol))
            End If
        End If
        rs.MoveNext
    Wend

    '// Dump result
    rng1.Value = "Checked"
    With rng2.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.349986266670736
        End With
    End With

End Sub