Public Sub InsertToTable()
    Const lastRow = 400000, lastCol = 12
    Dim pCon As New ADODB.Connection, pRSet As New ADODB.Recordset, vData As Variant
    Dim k As Long, t As Single, i As Long
    t = Timer: k = 0
    pCon.CursorLocation = adUseClient
    pCon.Open "DBQ=c:\Projects\Database2 min.accdb;Driver={Microsoft Access Driver (*.mdb, *.accdb)};DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;ReadOnly=0;ExtendedAnsiSQL=1;"
    pRSet.CursorLocation = adUseClient: pRSet.CursorType = adOpenStatic
    pRSet.Open "Select * From forImport Where FLong1 Is Null", pCon, adOpenStatic, adLockOptimistic
    vData = Range("A2").Resize(lastRow, lastCol).Value
    pCon.BeginTrans
    For i = 1 To lastRow
        k = k + 1
        If (k Mod 10000) = 0 Then Debug.Print k: DoEvents
        pRSet.AddNew
        pRSet(0).Value = vData(i, 1)
        pRSet(1).Value = vData(i, 2)
        pRSet(2).Value = vData(i, 3)
        pRSet(3).Value = vData(i, 4)
        pRSet(4).Value = vData(i, 5)
        pRSet(5).Value = vData(i, 6)
        '
        pRSet(6).Value = vData(i, 7)
        pRSet(7).Value = vData(i, 8)
        pRSet(8).Value = vData(i, 9)
        pRSet(9).Value = vData(i, 10)
        pRSet(10).Value = vData(i, 11)
        pRSet(11).Value = vData(i, 12)
    Next
    pRSet.UpdateBatch: pCon.CommitTrans
    pRSet.Close: pCon.Close
    MsgBox Timer - t
End Sub

Sub runAccess()
    Set acApp = CreateObject("Access.Application")
    acApp.OpenCurrentDatabase strFileName
    
    Set acDoCmd = acApp.DoCmd
    acDoCmd.TransferSpreadsheet 0, 9, "Лист1", "C:\...\...\MyFile.xlsx", True

    
    acApp.Quit
End Sub

pRSet(3).Value = vData(i, 4)

pRSet.AddNew

Option Explicit

Public Sub InsertToTable2()

    Const tableName$ = "Таблица1"
    Const DatabaseName$ = "D:\1tmp\Database3.accdb"
    Const hypl$ = "hypl"
    Const sSaveFolder$ = "D:\1tmp\"
    Const pIndexName$ = "Kod_Obj"

    '    Dim pCon As New ADODB.Connection, pRSet As New ADODB.Recordset
    Dim pCon As Object, pRSet As Object
    Dim vData As Variant, vvData As Variant
    Dim k As Long, i As Long, j&
    Dim strCon$, ctrSQL$, strFields$, strF$
    Dim sSavePath$
    Dim oDic As Object
    Dim inexColumn&, errCounter&

    Set oDic = CreateObject("Scripting.Dictionary")
    Set pCon = CreateObject("ADODB.Connection")
    Set pRSet = CreateObject("ADODB.Recordset")
    pCon.CursorLocation = 3  ' adUseClient

    vData = shData.Range("A1").CurrentRegion.Value
    ReDim vvData(1 To UBound(vData) - 1, 1 To UBound(vData, 2))
    strF = vData(1, 1)
    strFields = tableName & ".[Код]" & "," & tableName & ".[" & hypl & "]"
    For j = 1 To UBound(vData, 2)
        If vData(1, j) = pIndexName Then inexColumn = j
        strFields = strFields & "," & tableName & ".[" & vData(1, j) & "]"
    Next

    strCon = "DBQ=" & DatabaseName
    strCon = strCon & ";Driver={Microsoft Access Driver (*.mdb, *.accdb)};DriverId=25;FIL=MS Access;"
    strCon = strCon & "MaxBufferSize=2048;PageTimeout=5;ReadOnly=0;ExtendedAnsiSQL=1;"
    pCon.Open strCon

    pRSet.CursorLocation = 3    'adUseClient
    pRSet.CursorType = 3    'adOpenStatic

    ctrSQL = "SELECT " & strFields & " FROM " & tableName

    pRSet.Open ctrSQL, pCon, 3, 3
    '    pRSet.Open ctrSQL, pCon, adOpenStatic, adLockOptimistic
    pCon.BeginTrans

    Do    'While Not pRSet.EOF
        oDic.Item(pRSet.Fields(pIndexName).Value) = oDic.Count
        pRSet.MoveNext
        DoEvents
    Loop While Not pRSet.EOF
    k = pRSet.Fields.Count - UBound(vData, 2)

    For i = 2 To UBound(vData)
        If Not oDic.Exists(vData(i, inexColumn)) Then
            pRSet.AddNew
            For j = 1 To UBound(vData, 2)
                pRSet(j + k - 1).Value = vData(i, j)  ' код & гипер
            Next
        Else
            errCounter = errCounter + 1
            For j = 1 To UBound(vData, 2)
                vvData(errCounter, j) = vData(i, j)
            Next
        End If
    Next

    pRSet.UpdateBatch
    Do    'While Not pRSet.BOF

        If pRSet.EOF Then Exit Do

        If IsNull(pRSet.Fields(hypl).Value) Then
            sSavePath = sSaveFolder & CStr(pRSet![Код].Value)
'            If Dir(sSavePath, vbDirectory) = "" Then
'                MkDir (sSavePath)
'                DoEvents
'            End If
            pRSet.Fields(hypl).Value = CStr(pRSet![Код].Value) & "#" & sSavePath & "#"
        Else
            Exit Do
        End If
        pRSet.MovePrevious
        DoEvents
    Loop While Not pRSet.BOF

    pRSet.UpdateBatch: pCon.CommitTrans
    pRSet.Close: pCon.Close: Set oDic = Nothing
    shData.Range("A1").CurrentRegion.Offset(1).ClearContents
    shData.Range("A2").Resize(UBound(vvData), UBound(vvData, 2)) = vvData
    MsgBox "Готово"
End Sub