Any Other Way To Speed Up Code For INSERT INTO STATEMENTS for N Rows?

Question

Im making Codes Inserting Data into a autonumber Columns to a table that composes of Two COlumns. My Table is Access and Front End is Excel. My Access Table contains ID (which is AutoNumber) and Paycode which is base on a cell. I need this codes to use it as Unique IDs in which later on will post it back to Ms Access separate Table.

Sub ImportJEData()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim x As Long
Dim var
Dim PayIDnxtRow As Long

'add error handling
On Error GoTo errHandler:

'Variables for file path and last row of data
dbPath = Sheets("Update Version").Range("b1").Value
Set var = Sheets("JE FORM").Range("F14")

PayIDnxtRow = Sheets("MAX").Range("c1").Value

'Initialise the collection class variable
Set cnn = New ADODB.Connection

'Create the ADODB recordset object.
'Set rst = New ADODB.Recordset 'assign memory to the recordset

'Connection class is equipped with a —method— named Open
'—-4 aguments—- ConnectionString, UserID, Password, Options
'ConnectionString formula—-Key1=Value1;Key2=Value2;Key_n=Value_n;
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
'two primary providers used in ADO SQLOLEDB —-Microsoft.JET.OLEDB.4.0 —-Microsoft.ACE.OLEDB.12.0
'OLE stands for Object Linking and Embedding, Database




Do

    On Error Resume Next 'reset Err.obj.

         'Get the Max ID +1
        Set rst = Nothing
        Set rst = New ADODB.Recordset 'assign memory to the recordset
        SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
        rst.Open SQL, cnn

        'Check if the recordset is empty.
        If rst.EOF And rst.BOF Then
        'Close the recordet and the connection.
        Sheets("Max").Range("A2") = 1
        Else
        'Copy Recordset to the Temporary Cell
        Sheets("MAX").Range("A2").CopyFromRecordset rst

        End If

        'Insert the Data to Database And Check If no Errors
        Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
        cnn.Execute Sql2

Loop Until (Err.Number = 0)

'And if No errors COpy temporary to NEw Sub Temporary Data for Reference
Sheets("LEDGERTEMPFORM").Range("D1").Value = Sheets("MAX").Range("A2").Value



'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
        Set rst = Nothing
        Set rst = New ADODB.Recordset 'assign memory to the recordset
        rst.AddNew
        'Insert the Data to Database And Check If no Errors
        Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
        cnn.Execute Sql2

Next x
    Set rst = Nothing
    Set rst = New ADODB.Recordset 'assign memory to the recordset
    SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
    rst.Open SQL, cnn
    Sheets("PaySeries").Range("B2").CopyFromRecordset rst




    Set rst = Nothing


rst.Close
' Close the connection
cnn.Close
'clear memory
Set rst = Nothing
Set cnn = Nothing

'communicate with the user
'MsgBox " The data has been successfully sent to the access database"

'Update the sheet
Application.ScreenUpdating = True

On Error GoTo 0
Exit Sub
errHandler:

'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub

In this section Below Would like to know if theres another way without using or even faster type of loop.

'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
        Set rst = Nothing
        Set rst = New ADODB.Recordset 'assign memory to the recordset
        rst.AddNew
        'Insert the Data to Database And Check If no Errors
        Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
        cnn.Execute Sql2

Next x
    Set rst = Nothing
    Set rst = New ADODB.Recordset 'assign memory to the recordset
    SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
    rst.Open SQL, cnn
    Sheets("PaySeries").Range("B2").CopyFromRecordset rst

Answer 1

Finally Ive figured it Out it went better from 40 to 19s Thanks to the idea of @miki180.

Heres my code below starting from DO...

Do
On Error Resume Next 'reset Err.obj.

     'Get the Max ID +1
    Set rst = Nothing
    Set rst = New ADODB.Recordset 'assign memory to the recordset
    SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
    rst.Open SQL, cnn

    'Check if the recordset is empty.
    'Copy Recordset to the Temporary Cell
    Sheets("MAX").Range("A2").CopyFromRecordset rst

    'Insert the Data to Database And Check If no Errors
    Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
    cnn.Execute Sql2

Loop Until (Err.Number = 0)

xlFilepath = Application.ThisWorkbook.FullName

SSql = "INSERT INTO PaypaymentID(Apnumber) " & _
"SELECT * FROM [Excel 12.0 Macro;HDR=YES;DATABASE=" & xlFilepath & "].[MAX$G1:G15000] where APNumber > 1"

cnn.Execute SSql

 Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset

 SQL = "Select PayID From PayPaymentID where APNumber = " & _ 
Sheets("LEDGERTEMPFORM").Range("B8") & " order by PayID "

rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst