Importar un fitxer Excel a una taula Access vinculada a SQL Server

Amb aquest codi pots importar un fitxer Excel a una taula Access vinculada a SQL Server.

Dim ConSQLServer As ADODB.Connection
Dim Taula As ADODB.Recordset
Dim objExcel As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim Sortir As Boolean

Dim fDialog As Office.FileDialog
Dim varFile As Variant


' obres la connexió amb el servidor SQLServer i la taula on agregaràs els registres
Set ConSQLServer = New ADODB.Connection
Set Taula = New ADODB.Recordset

ConSQLServer.Open "Provider=sqloledb;" & _
"Data Source=[NomServidor];" & _
"Initial Catalog=[NomBaseDeDades];" & _
"User Id=[NomUsuari];Password=[Password]"

With Taula
    Set .ActiveConnection = ConSQLServer
        .Source = "SELECT * FROM rhNomines"
        .LockType = adLockOptimistic
        .CursorType = adOpenKeyset
        .Open
End With

'obres l'arxiu Excel
Set objExcel = Nothing
Set objExcel = New Excel.Application

Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

With fDialog
        ' Allow user to make multiple selections in dialog box
        .AllowMultiSelect = False
        ' Set the title of the dialog box to False.
        .Title = "Selecciona el fitxer a carregar"
        ' Clear out the current filters, and add our own.
        .Filters.Clear
        .Filters.Add "Tots els fitxers", "*.*"
        ' Show the dialog box. If the .Show method returns True, the
        ' user picked at least one file. If the .Show method returns
        ' False, the user clicked Cancel.
    If .Show = True Then
        'Loop through each file selected and add it to our list box.
     
        For Each varFile In .SelectedItems
            DoCmd.Hourglass True
            objExcel.Workbooks.Open FileName:=varFile
            objExcel.Visible = False ' perquè no es vegi la pantalla d'excel

            ' tens que establir una fila inicial del teu fitxer Excel
         
            Fila = 4
                With objExcel
                    Do
                    ' d'alguna manera has de definir quants registes agregaràs. '
                    ' Quan es troba amb una cel·la de la primera columna en blanc acaba ( Sortir = True )
                        If .Cells(Fila, 3) = "" Then
                            Sortir = True
                            Else
                            Sortir = False
                            Taula.AddNew
                            Taula("NifTreballador") = .Cells(Fila, 3)
                            Taula("DataNomina") = Me.txtData
                            Taula("TipusNomina") = Me.cboTipusNomina.Value
                            Taula("SalariNet") = .Cells(Fila, 6)
                            Taula("SalariBrut") = .Cells(Fila, 7)
                            Taula("Quilometratge") = .Cells(Fila, 8)
                            Taula("ProrrataPaguesExtres") = .Cells(Fila, 10)
                            Taula("QuotaObreraSS") = .Cells(Fila, 11)
                            Taula("RetencioIRPF") = .Cells(Fila, 12)
                            Taula("ITEnfermetatAccident") = .Cells(Fila, 13)
                            Taula("QuotaSSCarrecEmpresa") = .Cells(Fila, 14)
                            Taula("BonificacioQuotaSSEmpresa") = .Cells(Fila, 15)
                            Taula.Update
                            Fila = Fila + 1
                        End If
                    Loop Until Sortir
                End With
                 
            DoCmd.Hourglass False
        Next
             
            MsgBox "El fitxer s'han carregat correctament.", vbInformation, "Carrega finalitzada"
            DoCmd.Hourglass False
           
             Dim stDocName As String
             Dim stLinkCriteria As String

            stDocName = "frm_rhNomines_ComprovacioImportacio"
            DoCmd.OpenForm stDocName, , , stLinkCriteria
             
    Else
        MsgBox "No has carregat cap fitxer.", vbExclamation, "Càrrega cancelada"
    End If
End With

' hem acabat... la Taula ja té agregats els
' registres que estaven en Excel, ara es tanquen les taules
' i s'allibera l'aplicació Excel
Taula.Close
ConSQLServer.Close
objExcel.Workbooks.Close
Set objExcel = Nothing