Operacje na bazie danych Access .accdb poprzez Excel VBA

Mając jeszcze dostęp do programu Access wykonałem test połączenia VBA pomiędzy Excelem, a bazą danych Access .accdb. Obecnie niestety nie dysponuję licencją programu Access, także nie jestem w stanie sprawdzić poprawności kodu

UWAGA! Nie mam możliwości weryfikacji kodu, czy jest poprawny. Brak dostępu do programu Access.

Baza danych jest w tym samym folderze co plik Excela .xlsm co potwierdza użyty kod ThisWorkbook.Path (bazę danych trzeba utworzyć samemu). W tym poście archiwizuje jak stworzyć tablę, jak dodać rekordy, jak zaznaczyć rekordy i jak zaktualizować rekordy w tabeli bazy danych Access .accdb.

Ta stronka bardzo mi pomogła: stackoverflow.com.

Tworzenie tabeli w bazie danych Access .accdb za pomocą kodu VBA Excel:

(zastanawia mnie tylko fakt, że brak jest hasła do bazy danych – a hasło jest na pewno)

' https://stackoverflow.com/questions/30081993/ms-excel-to-ms-access-accdb-database-from-vba-sql-syntax-error
Sub Create_Table()
'!!!!!! Add Reference to Microsoft ActiveX Data Objects 2.x Library !!!!!!

Dim strConnectString        As String
Dim objConnection           As ADODB.Connection
Dim strDbPath               As String
Dim strTblName              As String
Dim wCL                     As Worksheet
Dim wCD                     As Worksheet

Set wCL = Worksheets("Sheet1")
' Set wCD = Worksheets("Contract Data")

'Set database name and DB connection string--------
strDbPath = ThisWorkbook.Path & "\TestDB.accdb"
'==================================================
' strTblName = wCL.Range("TableName").Value
'strTblName = ActiveSheet.Range(Cells(1, 1), Cells(2, 3))("TestTable").Value
strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDbPath & ";"

'Connect Database; insert a new table
Set objConnection = New ADODB.Connection
On Error Resume Next
With objConnection
    .Open strConnectString
    .Execute "CREATE TABLE " & "TEST2" & " (" & _
            "Imie text(20), " & _
            "Nazwisko text(30)," & _
            "Lat int)"
End With

Set objConnection = Nothing

End Sub

Dodawanie rekordów za pomocą VBA Excel do utworzonej bazy danych Access .accdb:

Sub INSERT_to_Table()
'!!!!!! Add Reference to Microsoft ActiveX Data Objects 2.x Library!!!!!!

Dim strConnectString        As String
Dim objConnection           As ADODB.Connection
Dim strDbPath               As String
Dim strTblName              As String
Dim strSQL                  As String
Dim ErrorMessage

'Set database name and DB connection string--------
strDbPath = ThisWorkbook.Path & "\TestDB.accdb"
'==================================================
strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & ThisWorkbook.Path & "\TestDB.accdb;" & _
                    "Jet OLEDB:Database Password='****';"
                    
                    '& _
                  '  "Mode=Share Exclusive"
'        strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDbPath & _
'    ";MS Access;PWD=asdf"

'Connect Database; insert a new table
Set objConnection = New ADODB.Connection
On Error GoTo ErrorMessage
With objConnection
    .Open strConnectString
    .Execute "INSERT INTO TEST" & _
            " (Imie,Nazwisko,Lat)" & _
            " VALUES ('Adam','Nowak',12)"

End With

Set objConnection = Nothing

Exit Sub

ErrorMessage:
MsgBox "OPIS: " & Err.Description & Chr(10) & _
    "NUMER: " & Err.Number
Set objConnection = Nothing

End Sub

Zaznaczanie rekordów z bazy danych:

(ale brak wklejenia danych do arkusza?)

Sub Select_Table_Records()
 'Add Reference to Microsoft ActiveX Data Objects 2.x Library
 Dim strConnectString        As String
 Dim objConnection           As ADODB.Connection
 Dim strDbPath               As String
 Dim strTblName              As String
 Dim strSQL                  As String

 'Set database name and DB connection string--------
 strDbPath = ThisWorkbook.Path & "\TestDB.accdb"
 '==================================================
 strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDbPath & ";"

 'Connect Database; select records
Set objConnection = New ADODB.Connection
On Error Resume Next
With objConnection
    .Open strConnectString
    .Execute "SELECT * FROM TEST"
End With

Set objConnection = Nothing

End Sub

Znalazłem też w swoich testowych plikach taki kod zaznaczenia danych (tu akurat jest wklejanie danych do arkusza):

' https://stackoverflow.com/questions/9083232/writing-excel-vba-to-receive-data-from-access
Private Sub Workbook_Open()
Dim cn As Object, rs As Object
Dim intColIndex As Integer
Dim DBFullName As String
Dim TargetRange As Range

On Error GoTo Whoa
Set TargetRange = ActiveSheet.Range("A1")

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=T:\Tablica\TestMDB.mdb;" & _
              "Jet OLEDB:Database Password='****';"

Set rs = CreateObject("ADODB.Recordset")
rs.Open "SELECT * FROM TEST2", cn, , , adCmdText

' Write the field names
For intColIndex = 0 To rs.Fields.Count - 1
    TargetRange.Offset(1 - 1, intColIndex).Value = rs.Fields(intColIndex).Name 'ori nie bylo -1
Next

' Write recordset
TargetRange.Offset(1, 0).CopyFromRecordset rs

LetsContinue:

On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
On Error GoTo 0
Exit Sub
Whoa:
MsgBox "Error Description :" & Err.Description & vbCrLf & _
   "Error at line     :" & Erl & vbCrLf & _
   "Error Number      :" & Err.Number
Resume LetsContinue
End Sub

Aktualizowanie tabeli w bazie danych Access poprzez Excel VBA:

Sub Update_Table()
'Add Reference to Microsoft ActiveX Data Objects 2.x Library
Dim strConnectString        As String
Dim objConnection           As ADODB.Connection
Dim strDbPath               As String
Dim strTblName              As String


'Set database name and DB connection string--------
strDbPath = ThisWorkbook.Path & "\TestDB.accdb"
'==================================================
strConnectString = "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDbPath & ";"

'Connect Database; insert a new table
Set objConnection = New ADODB.Connection
On Error Resume Next
With objConnection
    .Open strConnectString
    .Execute "UPDATE TEST" & _
            " SET Nazwisko='Kowalski', Lat=90" & _
            " WHERE Imie='Pawel'"

End With

Set objConnection = Nothing

End Sub

Dodaj komentarz

Twój adres email nie zostanie opublikowany. Wymagane pola są oznaczone *

Witryna wykorzystuje Akismet, aby ograniczyć spam. Dowiedz się więcej jak przetwarzane są dane komentarzy.