zunächst mal ein verspätetes schönes Neues Jahr Euch allen!
Ich hoffe Ihr könnt mir wie meistens wieder helfen:
Aus einem Exceltool heraus werden per ADO Daten auf einer Tabelle ("CIC") in eine Datenbank geschrieben.
Ich muss dabei verhindern, dass es dabei in einem bestimmten Feld zu Doppeleinträgen kommt.
Jetzt habe ich schon ein paar Stunden gegoogelt und herumprobiert, bekomme es aber irgendwie nicht hin. Wie müsste ich mein macro an der mit ? versehenen Stelle ändern?
Sub Update_Records_from_Excel_in_AccessII()
Dim FilterString, Fieldstring As String
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim DB_DatasourceString As String
Dim UpdateTime As Date
Dim Last_ConflictRow, hrow As Long
Dim Conflict As Boolean
Dim DSheet As Worksheet
Dim ChangeCounter As Integer
DB_DatasourceString = "Data Source=" & Replace(GenFileSet.Range("c8").Value, _
"%USERPROFILE%" , Environ("userprofile")) & GenFileSet.Range("c9").Value & Chr(59) _
& "Jet OLEDB:Database Password=Superpass" & Chr(59)
' connect to the Access database
Set cn = New ADODB.Connection
If LCase(Right(GenFileSet.Range("c9").Value, 3)) = "mdb" Then
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & DB_DatasourceString 'acces mdb
Else
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & DB_DatasourceString
End If
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "CIC", cn, adOpenKeyset, adLockOptimistic, adCmdTable
r = 10 ' the start row in the worksheet
WriteError = False
Set DSheet = CIC
CIC.Unprotect ("Automat")
Do While Len(CIC.Range("C" & r).Formula) > 0 ' repeat until first empty cell in column C
ChangeCounter = 0
FilterString = "DB_AutoID = " & Chr(39) & CIC.Cells(r, 100).Value & Chr(39)
rs.Filter = FilterString
If rs.Fields("last_Change") Empty Then
With rs
UpdateTime = Now
For j = 2 To 97
On Error Resume Next
Fieldstring = FieldContent(rs.Fields(tbl_col_matrix.Cells(COlRow + 3, j). _
Value))
If Err.Number 0 Then
Fieldstring = ""
Err.Clear
End If
If Fieldstring CIC.Cells(r, j).Value Then
If j = 93 Then
If ? 'Prüfen ob dieser Wert (CIC.Cells(r, j).Value) breits in _
DB
MsgBox ("Duplicate Values found")
CIC.Cells(j, 7).Select
Exit Sub
End If
End If
.Fields(tbl_col_matrix.Cells(COlRow + 3, j).Value) = CIC.Cells(r, j). _
Value
ChangeCounter = ChangeCounter + 1
Err.Clear
End If
Next j
If ChangeCounter > 0 Then
.Fields(tbl_col_matrix.Cells(COlRow + 3, 98).Value) = UpdateTime
CIC.Cells(r, 98).Value = UpdateTime
.Fields(tbl_col_matrix.Cells(COlRow + 3, 99).Value) = CIC.Cells(r, 99). _
Value 'country
.Update ' stores the changed record
If Err.Number 0 Then
WriteError = True
End If
End If
End With
End If
r = r + 1 ' next row
Loop
CIC.Protect
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Danke und Gruss
Theo