Opdatere data med VBA
Jeg bruger denne kode til at indsætte data fra et regneark i Access, men vil gerne have den udvidet, så hvis data allerede eksisterer i tabellen, bliver de bare opdateret.Option Explicit
Function MinFunktion(ark1 As String, range1 As String, userID As Variant, password As Variant, Optional ark2 As String, Optional range2 As String)
On Error GoTo Err_MinFunktion
'Eksportere data fra fast definerede regneark til SQL Server
Dim dataarea As Range, NumberOfRows As Integer
Dim dataheaders As Variant, x As Integer, r As Integer, cn As ADODB.Connection, rs As ADODB.Recordset
Set dataarea = Sheets(ark1).Range(range1)
dataheaders = dataarea.Resize(1, dataarea.Columns.Count)
Set dataarea = dataarea.Offset(1, 0).Resize(dataarea.Rows.Count - 1, dataarea.Columns.Count)
Set cn = New ADODB.Connection
cn.Open "Provider=SQLOLEDB;data Source=minServer;Initial Catalog=MinDatabase;User Id=" & userID & ";password=" & password
Set rs = New ADODB.Recordset
rs.Open "MinTabel", cn, adOpenKeyset, adLockOptimistic, adCmdTable
NumberOfRows = 0
For r = 1 To dataarea.Rows.Count
If dataarea(r, 1) <> 0 Then
NumberOfRows = NumberOfRows + 1
With rs
.AddNew
.Fields("Dato") = Worksheets(ark2).Range(range2).Value
For x = 1 To UBound(dataheaders, 2)
.Fields(dataheaders(1, x)) = dataarea(r, x)
Next
.Update
End With
End If
Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
If Err.Number = 0 Then
MsgBox "Der blev overført " & NumberOfRows & " rækker fra " & ark1 & " til databasen"
End If
Exit_MinFunktion:
Exit Function
Err_MinFunktion:
If Err.Number = -2147217873 Then
MsgBox "Data ER er allerede overført til databasen"
Else
MsgBox "Der opstod følgende fejl i programmet: " & vbCrLf & Err.Number & " - " & Err.Description, vbInformation
End If
Resume Exit_MinFunktion
End Function
Men ADODB.Recordset lader sig vist ikke bare opdatere nemt, vel?
Primærnøglen i tabellen er værdien af .Fields("Dato") = Worksheets(ark2).Range(range2).Value sammen med .Fields(dataheaders(1, x)) = dataarea(r, x) der hvor x = 1
