我正在尝试将SQL Server数据写入Excel工作表，但是速度非常慢。有什么要优化的吗？在20 cColumns上大约需要4000个条目，耗时6-7分钟。

数据库（“ freigabe”）模块：连接到数据库并获取RecordSet （这就像一种魅力）

Private Function ConnectSQL() As ADODB.Connection
    Set conn = New ADODB.Connection
        conn.ConnectionString = "DRIVER={SQL Server};" _
            & "SERVER=xxxxx;" _
            & " DATABASE=xxxxx;" _
            & "UID=xxxxxx;PWD=xxxxx; OPTION=3"

        conn.Open

    Set ConnectSQL = conn
End Function

Public Function load(Optional ByVal FieldName As String = "",Optional ByVal fieldValue As String = "",Optional ByVal ComparisonOperator As String = "=")
'wenn fehler return?
'-> Über errorhandler retun rs oder boolen
    Dim rs As New ADODB.Recordset
    Dim sql As String
    Dim contition As String

    contition = " "

    Dim sqlfrom As String
    Dim sqlto As String


On Error GoTo Fehler:


    sql = "SELECT * FROM " & TBLNAME & " WHERE storno='0' AND created BETWEEN '2020-02-01' AND '2020-02-15'"

    Set conn = ConnectSQL()
        rs.Open sql,conn,adOpenStatic
    Set load = rs

    Exit Function
    End If
Fehler:
    load = Err.Description
End Function

获取/写入：建立连接并检索记录集。 While循环需要很长时间。我正在跳过文本丰富的列（它会变快但仍然太长）。显示一个加载窗口，以便该人员不认为Excel“不起作用”。之后，将对数据进行验证（不包括在内）。

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationmanual

    Dim rs As Recordset
    Dim k As Integer
    Dim i As Integer

    Dim startt As Double
    Dim endt As Double

    Dim rngDst As Range

    Set rs = freigabe.load()


    Set rngDst = Worksheets("Freigaben").Range("G2")

    With Worksheets("Freigaben").Range("g2:Z50000")
        .ClearContents
        '.CopyFromRecordset rs
    End With
    Count = rs.RecordCount
    k = 0


    gui_laden.Show

    startt = Timer
    With rs
        If Not .BOF And Not .EOF Then
            .MoveLast
            .MoveFirst
            While Not .EOF
                For i = 0 To .Fields.Count - 1
                    If i <> 13 And i <> 2 And i <> 10 And i <> 5 And i <> 6 And i <> 0 Then  rngDst.Offset(,i) = .Fields(i).Value 'skip unneccessary data and write
                Next i
                k = k + 1
                Debug.Print k & "/" & Count
                gui_laden.lbl_status = "Lade Daten herunter: " & k & "/" & Count
                gui_laden.Repaint
                .MoveNext
                DoEvents 'Ensure Application doesn't freeze
                Set rngDst = rngDst.Offset(1)
            Wend
        End If
    End With

    endt = Timer - startt
    Debug.Print "Dauer: " & endt

我尝试过的事情：

1. CopyFromRecordSet->应用程序冻结
2. 在新工作簿中测试->相同

非常感谢您！