Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Doppelte Einträge vermeiden ADO | Herbers Excel-Forum


Betrifft: Doppelte Einträge vermeiden ADO von: Fettertiger
Geschrieben am: 16.01.2012 17:55:49

Hallo liebe Experten,

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

  

Betrifft: AW: Doppelte Einträge vermeiden ADO von: Josef Ehrensberger
Geschrieben am: 16.01.2012 19:02:09


Hallo Theo,

evtl. solltest du schon bei der Abfrage doppelte Vermeiden (Stichwort DISTINCT), sonst z. B. so.

If IsNumeric(Application.Match(CIC.Cells(r, j), CIC.Columns(j), 0)) Then
  MsgBox ("Duplicate Values found")
  CIC.Cells(j, 7).Select
  Exit Sub
End If





« Gruß Sepp »



  

Betrifft: AW: Doppelte Einträge vermeiden ADO von: Fettertiger
Geschrieben am: 17.01.2012 09:32:39

Hallo Sepp,

ich hätte wohl etwas mehr über das Tool erzählen sollen, denn bevor das Makro überhaupt startet führe ich den Check schon in ähnlicher Form durch.

Bei dem Tool nutze ich Excel als "Eingabe - und Verarbeitungstool" für Daten die im Hintergrund auf einer ACCDB gespeichert sind. Wenn ein Nutzer Daten aus der Datenbank nach Excel einliest, bekommt er dabei auch nur die für ihn relevanten Daten nach Excel geladen.

Deshalb "erschlägt" der von Dir vorgeschlagene Check nur einen Teil der Fehler, denn der entsprechende "doppelte" Wert kann durchaus einem anderen User zugeordnet sein.

Vielen Dank fürs weitersuchen

Grüße

Theo


  

Betrifft: AW: Doppelte Einträge vermeiden ADO von: Josef Ehrensberger
Geschrieben am: 17.01.2012 09:50:58


Hallo Theo,

und nun?

Nur du kennst den Aufbau deiner Tabelle und nur du weißt, was, wann und wo geprüft werden soll.




« Gruß Sepp »



  

Betrifft: AW: Doppelte Einträge vermeiden ADO von: Fettertiger
Geschrieben am: 17.01.2012 11:39:33

Hallo nochmal,

manchmal kann es dann doch ganz einfach gehen:

Ich fange jetzt einfach den Fehler beim ".Update" ab mit

If Err.Number <> 0 Then
If Err.Number = -2147217887 Then
MsgBox "The XYZ combination already exists" & Chr(10) & _
"Please correct!" & Chr(10) & "The database was not synced!", vbCritical, "Duplicate XYZ Combination"
CIC.Cells(r, 7).Select
With CIC.Cells(r, 7).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
MsgBox ("Unexpected error during Writing to Database" & Chr(10) & _
"Errornumber: " & Err.Number)
End If
WriteError = True
Err.Clear
End If

Damit funzt es jetzt einwandfrei!

Danke und Gruss

Theo


Beiträge aus den Excel-Beispielen zum Thema "Doppelte Einträge vermeiden ADO"