Opdater access database fra Excel
Hej har fundet en kode på nettet som jeg prøver at arbejde med, men den kommer med en fejl.Jeg har et excel ark Telefontider.xls og en database der heddder Tider2.mdb
Det er syntaks fejl på linien
.FindFirst "Field1='" & MyLookupValue & "'"
Koden ser således ud
Hvad kan jeg gøre?
'=============================================================================
'- UPDATE AN ACCESS RECORD FROM EXCEL
'- FIND SPECIFIED RECORD IN AN ACCESS TABLE FROM EXCEL
'=============================================================================
'- EXCEL : GETS LOOKUP VALUE FROM ROW CONTAINING SELECTED CELL COLUMN A
'- ACCESS : CHECKS CORRECT RECORD FOUND
'- ACCESS : REPLACES RECORD VALUES WITH EXCEL WORKSHEET VALUES
'- We save code by "changing" field values even if they are the same.
'- Brian Baulsom November 2008
'=============================================================================
Dim ws As Worksheet
Dim FromRow As Long
Dim FromCol As Integer
Dim MyColumnCount As Integer
Dim MyPath As String
Dim db As Database
Dim MyTable As Recordset
Dim MyLookupValue As String
Dim MyMsg As String
Dim MsgLine1 As String
Dim strCriteria As String
Dim rsp
'=============================================================================
'- MAIN ROUTINE
'=============================================================================
Sub UPDATE_RECORD()
'-------------------------------------------------------------------------
'- ASSUMES ACCESS .MDB IS IN THE SAME FOLDER AS THIS WORKBOOK
MyPath = ThisWorkbook.Path & "\"
ChDrive MyPath
ChDir MyPath
'-------------------------------------------------------------------------
'- EXCEL : GET LOOKUP VALUE & NUMBER OF COLUMNS
Set ws = ActiveSheet
With ws
FromRow = ActiveCell.Row
MyColumnCount = .Cells(FromRow, .Columns.Count).End(xlToLeft).Column
MyLookupValue = .Cells(FromRow, "A").Value
End With
'-------------------------------------------------------------------------
'- ACCESS : SET RECORDSET = TABLE
Set db = DBEngine(0).OpenDatabase(MyPath & "tider2.mdb")
Set MyTable = db.OpenRecordset("Tabel", dbOpenDynaset)
With MyTable
'---------------------------------------------------------------------
'- DO LOOKUP. HERE USES FIELD CALLED "Field1"
.FindFirst "Field1='" & MyLookupValue & "'"
'---------------------------------------------------------------------
'- CHECK IF MATCH FOUND
If .NoMatch Then
MsgBox (MyLookupValue & " not found.")
GoTo GetOut
Else
'------------------------------------------------------------------
'- MESSAGE TO CHECK CURRENT RECORD
MsgLine1 = "FOUND RECORD CONTENTS BELOW. OK to change ?"
GetMessage ' SUBROUTINE
rsp = MsgBox(MyMsg, vbOKCancel, " FOUND RECORD")
If rsp = vbCancel Then GoTo GetOut
'------------------------------------------------------------------
'- UPDATE ACCESS RECORD
.Edit
For FromCol = 1 To MyColumnCount
.Fields(FromCol - 1).Value = ws.Cells(FromRow, FromCol).Value
Next
.Update
'------------------------------------------------------------------
End If
End With
'--------------------------------------------------------------------------
'- CONFIRMATION MESSAGE
MsgLine1 = "CONFIRM CHANGE"
GetMessage ' SUBROUTINE
rsp = MsgBox(MyMsg, vbOKOnly, " CURRENT POSITION")
'--------------------------------------------------------------------------
GetOut:
MyTable.Close
db.Close
Set MyTable = Nothing
Set db = Nothing
End Sub
'=============================================================================
'- SUBROUTINE TO SET UP MESSAGE
'- aligns XL values using spaces (not an exact science)
'=============================================================================
Private Sub GetMessage()
Dim XLval As Variant
Dim ACval As Variant
Dim XLalignment As Integer ' MESSAGE ALIGN XL COLUMN WITH SPACES
XLalignment = 30
'-------------------------------------------------------------------------
With MyTable
MyMsg = MsgLine1 & vbCr & vbCr _
& "ACCESSS" & Space(XLalignment) & "EXCEL" & vbCr & vbCr
'---------------------------------------------------------------------
'- CHECK COLUMNS
For FromCol = 1 To MyColumnCount
XLval = ws.Cells(FromRow, FromCol)
ACval = .Fields(FromCol - 1).Value
MyMsg = MyMsg _
& .Fields(FromCol - 1).Name & " : " & ACval _
& Space(XLalignment - Len(CStr(ACval))) _
& IIf(XLval = ACval, " = ", "---->> *") & XLval & vbCr
Next
End With
End Sub
'-----------------------------------------------------------------------------