Медленная петля. Ищете способ выполнить несколько записей за выполнение

Question

У меня есть книга Excel, которая содержит около 5000 строк данных. У меня есть две кнопки, связанные с макросами. Одна кнопка удалит все данные в таблице и снова вставит их из книги Excel, а другая вставит только «новые» строки на основе уникального идентификатора.

Я обнаружил, что обе эти кнопки долго работают. ~ 10-15 минут. Прямо сейчас он выполняет вставку для каждого ряда, но я хочу объединить это.

По сути, я хотел бы пройтись по ~ 100 или около того строкам, а затем вставить. Затем переберите следующие сто строк и вставьте.

Любые предложения будут с благодарностью. VBA / Кодирование в целом не моя сильная сторона, и я потяну кирпичную стену на этом.

Спасибо!

Sub Rebuild_Click()

' ***********************
' ** Declare Variables **
' ***********************
    Dim conn As New ADODB.Connection
    Dim iRowNo As Integer
    Dim sSTATUS, sCHANNEL, sISSUE, sLOB, sDESC, sIN, sJN, sIS, sPRIME, sIU, sTR, sAU As String
    Dim answer, sQTY, sRRSC, sOA, sMeetings, sOutages As Integer
    Dim sDATE As Date
    With Sheets("OASYS ADMIN TRACKER")

' ****************************
' ** Show Information Popup **
' ****************************
        answer = MsgBox("You are about to update the database with ~5,000 records." & vbCrLf & "" & vbCrLf & "This will take approximately 5 minutes." & vbCrLf & "" & vbCrLf & "If you wish to continue, please press Yes. Otherwise, Press No" & vbCrLf & "" & vbCrLf & "----------" & vbCrLf & "EXCEL IS NOT FROZEN." & vbCrLf & "" & vbCrLf & "****DO NOT CLOSE EXCEL ****", vbYesNo + vbQuestion, "Update Database")

' ***********************
' ** Open IF Statement **
' ***********************
        If answer = vbYes Then

            ' ***********************
            ' ** Connection String **
            ' ***********************
                conn.Open "Provider=SQLNCLI11;Password=XXXXX;User ID=XXXXX;Initial Catalog=SupportAdmin;Data Source=tcp:XXXXX;"

            ' *************************
            ' ** Purge Existing Data **
            ' *************************
                conn.Execute "Delete FROM dbo.TestDB"

            ' *********************
            ' ** Skip Leader Row **
            ' *********************
                iRowNo = 4

            ' ************************
            ' ** Begin Dataset Loop **
            ' ************************
                Do Until .Cells(iRowNo, 3) = ""
                    sID = .Cells(iRowNo, 1)
                    sSTATUS = .Cells(iRowNo, 2)
                    sDATE = .Cells(iRowNo, 3)
                    sCHANNEL = .Cells(iRowNo, 4)
                    sISSUE = .Cells(iRowNo, 5)
                    sQTY = .Cells(iRowNo, 6)
                    sLOB = .Cells(iRowNo, 7)
                    sDESC = .Cells(iRowNo, 8)
                    sIN = .Cells(iRowNo, 9)
                    sJN = .Cells(iRowNo, 10)
                    sIS = .Cells(iRowNo, 11)
                    sPRIME = .Cells(iRowNo, 12)
                    sIU = .Cells(iRowNo, 13)
                    sTR = .Cells(iRowNo, 14)
                    sAU = .Cells(iRowNo, 15)
                    sRRSC = .Cells(iRowNo, 16)
                    sOA = .Cells(iRowNo, 17)
                    sOutages = .Cells(iRowNo, 18)
                    sMeetings = .Cells(iRowNo, 19)

            ' ***********************
            ' ** Replace ' in Data **
            ' ***********************
                sDESC = Replace(sDESC, "'", "''")
                sIS = Replace(sIS, "'", "''")
                sIU = Replace(sIU, "'", "''")

            ' *****************
            ' ** Execute SQL **
            ' *****************
                conn.Execute "insert into dbo.TestDB (ID,STATUS,DATE,CHANNEL,ISSUE,QTY,LOB,[DESC],[IN],JN,[IS],PRIME,IU,TR,AU,RRSC,OA,OUTAGES,MEETINGS) " & _
                             "values ('" & sID & "','" & sSTATUS & "', '" & sDATE & "','" & sCHANNEL & "', '" & sISSUE & "', '" & sQTY & "', '" & sLOB & "', '" & sDESC & "', '" & sIN & "', '" & sJN & "', '" & sIS & "', '" & sPRIME & "', '" & sIU & "', '" & sTR & "', '" & sAU & "', '" & sRRSC & "', '" & sOA & "', '" & sOutages & "', '" & sMeetings & "')"

                iRowNo = iRowNo + 1
             Loop

' ****************************
' ** Show Information Popup **
' ****************************
        MsgBox "Database Update Complete!"

' *****************************
' ** Close Connection String **
' *****************************
        conn.Close
        Set conn = Nothing

' ****************************
' ** Close IF Statement **
' ****************************
        Else
           ' do nothing
     End If

    End With

End Sub

Answer 1

Попробовал ваш код с помощью временной таблицы в локальном SQL Server 2005 и обнаружил, что на 5000 записей уходит всего 10 секунд.В вашем случае задержка может быть связана с размером базы данных, скоростью сети и т. Д.

Однако после попытки с помощью кода вставлять 100 записей одновременно уменьшилось до 1 нечетной секунды.

Sub test2()
Dim conn As New ADODB.Connection
Dim LastRow As Long, LastCol As Long, iRowNo As Long, DataArr As Variant
Dim SqStr As String, ValStr As String, Rw As Long, Cl As Long
Dim Ws As Worksheet, tm As Double
tm = Timer

conn.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;;Initial Catalog=test;Data Source=USER-PC\SQLEXPRESS"
conn.Execute "Delete FROM dbo.Test"

Set Ws = ThisWorkbook.Worksheets("Sheet1")
iRowNo = 4
LastRow = Ws.Range("C" & Rows.Count).End(xlUp).Row
DataArr = Ws.Range("A" & iRowNo & ":S" & LastRow)
LastCol = UBound(DataArr, 2)

SqStr = "insert into dbo.Test (ID,STATUS,DATE,CHANNEL,ISSUE,QTY,LOB,[DESC],[IN],JN,[IS],PRIME,IU,TR,AU,RRSC,OA,OUTAGES,MEETINGS) "
'Sqlstr=Sqlstr & " Values "  'May use for Sql Server 2008 and above

    For Rw = 1 To UBound(DataArr, 1)
    DataArr(Rw, 1) = Replace(DataArr(Rw, 1), "'", "''")
    DataArr(Rw, 8) = Replace(DataArr(Rw, 8), "'", "''")
    DataArr(Rw, 13) = Replace(DataArr(Rw, 13), "'", "''")
    'ValStr = ValStr & "('"   'May use for Sql Server 2008 and above
    ValStr = ValStr & "Select '"
        For Cl = 1 To UBound(DataArr, 2)
        'ValStr = ValStr & DataArr(Rw, Cl) & IIf(Cl < LastCol, "','", "')")  'May use for Sql Server 2008 and above
        ValStr = ValStr & DataArr(Rw, Cl) & IIf(Cl < LastCol, "','", "'")   ' Used for test in Sql Server 2005
        Next Cl

        If Rw Mod 100 = 0 Then  ' exceute at 100 records
        ValStr = SqStr & ValStr
        conn.Execute ValStr
        DoEvents
        ValStr = ""
        Debug.Print Rw, Timer - tm
        Else
            If Rw < UBound(DataArr, 1) Then
            'ValStr = ValStr & ", "  'Modify Comma / Space between datasets of two rows according Sql version Syntax
            ValStr = ValStr & " UNION ALL "  'Used for test with Sql Server 2005.
            End If
        End If
    Next Rw

    If Rw Mod 100 > 0 Then
    ValStr = SqStr & ValStr
    conn.Execute ValStr
    DoEvents
    ValStr = ""
    Debug.Print Rw, Timer - tm
    End If


Debug.Print "Total Seconds Taken: " & Timer - tm
End Sub

Синтаксис INSERT SQl вместе со строкой подключения и т. Д. Может быть изменен для используемого вами типа и версии вместе с предложением в комментарии @Raymond Nijland.