Eksporter data fra Excel til Access (ADO)

Dersom du vil eksportere data fra et regneark til en tabell i en Access database kan du benytte makroen nedenfor:

Sub ADOFromExcelToAccess()
' eksporterer data fra det aktive regnearket til en tabell i en Access database
' denne prosedyren på tilpasses før bruk
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
    ' koble til Access databasen
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
        Data Source=C:\FolderName\DataBaseName.mdb;"
    ' åpne et recordset
    Set rs = New ADODB.Recordset
    rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable  
    ' alle posten i en tabell
    r = 3 ' startraden i regnearket
    Do While Len(Range("A" & r).Formula) > 0 
    ' gjenta inntil første tomme celle i kolonne A
        With rs
            .AddNew ' lag en ny datapost
            ' fyll inn verdier for hvert felt i posten
            .Fields("FieldName1") = Range("A" & r).Value
            .Fields("FieldName2") = Range("B" & r).Value
            .Fields("FieldNameN") = Range("C" & r).Value
            ' legg til flere felt hvis nødvendig...
            .Update ' lagrer den nye dataposten
        End With
        r = r + 1 ' neste rad i regnearket
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Eksempelmakroen forutsetter at ditt VBA-prosjekt har en referanse til ADO objektbiblioteket.
Dette gjøres i VBE ved ved å velge menyvalget Verktøy, Referanser og krysse av for Microsoft ActiveX Data Objects x.x Object Library.
Bruk ADO hvis du kan velge mellom ADO og DAO for import og eksport av data.

Nedenfor er et utvidet eksempel som viser hvordan man kan eksportere data fra flere arbeidsbøker:

Sub ExportMultipleFiles()
Dim fn As Variant, f As Integer
Dim cn As ADODB.Connection
    ' select one or more files
    fn = Application.GetOpenFilename("Excel-files,*.xls", _
        1, "Velg en eller flere arbeidsbøker med grunnlagsdata", , True)
    If TypeName(fn) = "Boolean" Then Exit Sub
    ' koble til en Access database
    Set cn = New ADODB.Connection
    On Error GoTo DisplayErrorMessage
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\FolderName\DataBaseName.mdb;"
    On Error GoTo 0
    If cn.State <> adStateOpen Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    ' gjenta for hver av de valgte filene
    For f = LBound(fn) To UBound(fn)
        Debug.Print "Valgt fil #" & f & ": " & fn(f)
        Application.StatusBar = "Eksporterer data fra " & fn(f) & "..."
        ExportFromExcelToAccess cn, CStr(fn(f))
        Application.StatusBar = False
    Next f
    Application.ScreenUpdating = True
    ' close the database connection
    cn.Close
    Set cn = Nothing
    MsgBox "Dataeksporten er ferdig!", vbInformation, ThisWorkbook.Name
    Exit Sub

DisplayErrorMessage:
    MsgBox Err.Description, vbExclamation, ThisWorkbook.Name
    Resume Next
End Sub

Sub ExportFromExcelToAccess(cn As ADODB.Connection, strFullFileName As String)
' eksporterer data fra en arbeidsboktil en tabell i en Access database
' prosedyren må redigeres før bruk
Dim wb As Workbook, rs As ADODB.Recordset, r As Long, f As Integer
    If cn Is Nothing Then Exit Sub
    If cn.State <> adStateOpen Then Exit Sub
    
    ' åpne arbeidsboken med grunnlagsdataene
    On Error GoTo DisplayErrorMessage
    Set wb = Workbooks.Open(strFullFileName, True, True)
    On Error GoTo 0
    If wb Is Nothing Then Exit Sub ' kunne ikke åpne arbeidsboken
    
    ' aktiver regnearket med grunnlagsdataene
    wb.Worksheets(1).Activate
    
    ' opprett et nytt recordset
    Set rs = New ADODB.Recordset
    ' åpne et recordset, alle data fra en tabell
    On Error GoTo DisplayErrorMessage
    rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' eller bruk en sql spørring som returnerer et tomt recordset
    'rs.Open "select * from TableName where SomeFieldName = -1", _
    '    cn, adOpenKeyset, adLockOptimistic, adCmdText
    On Error GoTo 0
    If rs.State = adStateOpen Then ' klarte å åpne recordset-et
        r = 2 ' første rad med data i regnearket
        Do While Len(Range("A" & r).Formula) > 0
            ' gjenta inntil første tomme celle i kolonne A
            With rs
                .AddNew ' opprett en record
                ' legg til data i feltene
                For f = 1 To .Fields.Count
                    .Fields(f - 1).Value = Cells(r, f).Value
                Next f
                .Update ' lagre den nye record-en
            End With
            r = r + 1 ' neste rad
        Loop
        rs.Close
    End If
    Set rs = Nothing
    
    ' lukk arbeidsboken uten å lagre endringer
    wb.Close False
    Exit Sub
    
DisplayErrorMessage:
    MsgBox Err.Description, vbExclamation, ThisWorkbook.Name
    Resume Next
End Sub

Dokumentet er sist oppdatert 2005-02-01 20:31:24 Utskriftsvennlig versjon

Brukerkommentarer:

Ole P. fra Trondheim skrev (2004-01-10 00:21:32 CET):

Re: Oppdatere eksisterende data
Finn frem til den posten i tabellen som skal oppdateres (med en SELECT-spørring eller Find-metoden i ADO).
Oppdater de feltene i posten som skal endres f.eks. slik:
rs.Fields("Kundenavn").Value = "NyttKundenavn"
rs.Update ' oppdaterer og lagrer endringene i posten

Man kan eventuelt åpne et recordset med flere poster og redigere hver enkelt post slik:
With rs
'.Open TableName, cn, adOpenForwardOnly, adLockOptimistic, adCmdTable ' hele tabellen
.Open "SELECT * FROM " & TableName, cn, adOpenForwardOnly, adLockOptimistic, adCmdText
Do While Not .EOF
.Fields(1).Value = Format(Date, "yyyy-mm-dd") ' endrer feltet til dagens dato
.Update ' lagrer endringene
.MoveNext ' flytter til neste post
Loop
End With

Trond Larsen fra Norway skrev (2004-01-08 23:32:13 CET):

Oppdatere eksisterende data
Er det mulig å gjøre det slik at man med denne kan oppdatere data som allerede finnes i tabellen?
I et konkret eksempel jeg har vil man kunne ønske å oppdatere bare noen kolonner i en tabell med nye data lagt inn i Excel (fordi det er lettere og raskere å jobbe med)