vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#

https://www.vbarchiv.net
Rubrik: Access   |   VB-Versionen: VBA06.10.06
ACCESS: Duplikate schnell anzeigen, ändern, löschen

Mit diesem Code lassen sich in MS-Access Duplikate suchen, ändern / bearbeiten, sortieren und löschen, wobei die relevanten Felder angegeben werden können

Autor:   Richard MittelstädtBewertung:  Views:  23.274 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Mit diesem Code lassen sich in MS-Access Duplikate suchen, ändern / bearbeiten, sortieren und löschen, wobei die relevanten Felder angegeben werden können.

Option Compare Database
Option Explicit
 
Public Function DuplikateRecordSourceVonTabelle( _
  T_NAM, _
  RST_COUNT, _
  Optional ORDER_DESC As Boolean = True, _
  Optional ALL_FLDs As Boolean = True, _
  Optional Fld_ARRAY)
  ' *********************************************************************************
  ' Funktion sucht Duplikate in einer Tabelle (AUCH LEERE Duplikate !!! )
  ' und gibt den RecordSource-String für die gefundene Auswahl zurück.
  ' Um auch Leerwerte zu finden, wird zwischenzeitlich eine "Null-Dummy-HilfsTabelle"
  ' per SQL angelegt ("<TabName>_DuplikateDummy") .
  ' Diese HilfsTabelle enthält zusätzlich für jedes Feld
  ' (ausser für das Auto-Feld) die
  '             ein Feld "ND_<FeldName>" mit dem Inhalt:   "!" & <Feld>  .
  ' Leer-Werte und Null-Werte werden dadurch (immer) gleich bewertet !!!
  ' Das Zeichen ! ist hoffentlich immer beim Sortieren das 1. Zeichen,
  ' ansonsten muss ein anderes Zeichen verwendet werden (Variable F_STRG setzen) .
  ' 
  '  -> Die Tabelle muss ein AUTO-Feld  MIT PRIMÄRSCHLÜSSEL !!!!   besitzen !
  '     (kann man meist einfach auch später dazu tun.)
  '     Ohne Primärschlüssel ist keine Bearbeitung der Sätze möglich ! 2006-09-16
  ' 
  ' Die gefundene Auswahl ist BEARBEITBAR !!! (Ändern + Löschen + Sortieren mögl.)
  ' 
  ' -------------- Parameter -----------------------------------------------
  '    T_NAM           Tabellen-Name
  '    RST_COUNT       Anzahl der Sätze (Rückabe-Wert ! zum Auswerten)
  ' 
  '    ORDER_DESC      Sortierung (in den "Duplikate-Gruppen") Abwärts
  '        Standard-Wert-> True  -> Neuere stehen oben
  '                        False -> Ältere stehen oben
  ' 
  '    ALL_FLDs        Alle Felder, auch nicht relevante mit ausgeben
  '    Fld_ARRAY       Feld mit FeldNamen der relevanten Tabellen-Felder:
  '                    Fld_ARRAY(0)        (nicht benutzt)
  '                    Fld_ARRAY(1...n)    Feld-Namen
  ' 
  ' Wird kein ARRAY mit FeldNamen angegeben, dann werden alle Felder
  ' (ausser Ole- und Auto-Wert-Felder) berücksichtigt.
  ' 
  ' -------------- Ablauf --------------------------------------------------
  '    1. Tabelle vorhanden ?
  '    2. AutoWert-Feld vorhanden ?
  '    3. SQL-String generieren zum Erzeugen der Dummy-HilfsTabelle
  '       und die Tabelle erstellen .
  '    4. Duplikate-RecordSource-String generieren .
  '       Dabei ermöglicht die Dummy-HilfsTabelle das Gruppieren,
  '       ohne LeerFelder zu "verlieren" .
  ' *********************************************************************************
 
  Dim tbl1 As TableDef
  Dim fld1 As Field, fld2 As Field, fld3 As Field
  Dim rst1 As Recordset, rst2 As Recordset
  Dim S_TXT       ' SQL-Text zum Erstellen der Hilfs-Tabelle
  Dim S_TXT2      ' Source-Text für Duplikate-Recordset
 
  Dim i, n
  Dim ANZ_FIELDs  ' Anzahl zu untersuchender Tabellen-Felder
  Dim ANZ_RFLDs   ' Anzahl der restlichen (nicht relevanten) Felder
  Dim AUTO_FLD    ' Evtl. vorhandenes Autowert-Feld
 
  Dim t1, t2, t3, t4, t5, t6, t7, t8, t9, t20, X  ' Texte
  Dim F_STRG      ' Erster String beim Sortieren (First String..)
 
  On Error GoTo ERR_01
  DuplikateRecordSourceVonTabelle = ""
  RST_COUNT = 0   ' Anzahl der Sätze (Rückabe-Wert ! zum Auswerten)
  F_STRG = "!"    ' Ist hoffentlich immer der erste String beim Sortieren (First String..)
 
  ' *** 1. Tabelle vorhanden ?*************************************
  For Each tbl1 In CurrentDb.TableDefs
    If tbl1.Name = T_NAM Then
      GoTo WEIT1      ' OK Tabelle existiert
    End If
  Next tbl1
  MsgBox "Tabelle " & T_NAM & "  existiert nicht !", _
    vbExclamation, "Tabelle nicht gefunden..."
  Exit Function
 
WEIT1:
  ' *** 2. AutoWert-Feld vorhanden ? ******************************
  AUTO_FLD = ""
  For Each fld1 In tbl1.Fields
    ' --- Autowert-Feld in Tabelle vorhanden ?, dann danach ordnen ---
    ' MsgBox fld1.Name & ":  " & fld1.Type & "  " & fld1.Attributes
    If fld1.Type = dbLong And fld1.Attributes = 17 Then    ' Feld Auto-Inkr/-Zufall
      AUTO_FLD = fld1.Name
      GoTo WEIT2      ' OK Auto-Feld existiert
    End If
  Next fld1
  t1 = "Tabelle " & T_NAM & "  hat kein AutoWert-Feld !" & vbNewLine & vbNewLine
  t2 = "Bitte versuchen:  Auto-Feld zur Tabelle fügen ." & vbNewLine & vbNewLine
  MsgBox t1 & t2, vbExclamation, "Tabelle nicht gefunden..."
  Exit Function
 
WEIT2:
  Dim Fld_ARRAY2()    ' Zwischenspeicher für relevante FeldNamen
  ' **** Keine Felder angegeben ?, dann alle Felder vergleichen *******
  If IsMissing(Fld_ARRAY) Then
    ' MsgBox tbl1.Fields.Count
    i = 0
    For Each fld1 In tbl1.Fields
      ' ---- Autowerte und Ole ausschliessen ! -------------------------
      ' MsgBox fld1.Name & ":  " & fld1.Type & "  " & fld1.Attributes
      ' OLE Object     LONGBINARY      dbLongBinary 11
      ' Auto Number    COUNTER (seed, increment) dbLong with attributes 4
      ' 4   Attr 17 Autowert Inkrement/Zufall
      ' Number: Replica GUID           dbGUID      15
      ' 15  Attr  1 Repl. ID
      If fld1.Type = dbLongBinary Then GoTo WEIT3 ' Ole
      If fld1.Type = dbLong And fld1.Attributes = 17 Then GoTo WEIT3   ' Auto-Inkr/-Zufall
      If fld1.Type = dbGUID Then GoTo WEIT3       ' Auto Repl. ID
      i = i + 1                       ' Neue Feld-Dimension
      ReDim Preserve Fld_ARRAY2(i)    ' Neue Feld-Dimension einstellen
      Fld_ARRAY2(i) = fld1.Name
WEIT3:
    Next fld1
    Fld_ARRAY = Fld_ARRAY2
  End If
 
  ' Restliche Felder merken für evtl. später "Alle Felder ausgeben"
  Dim Fld_ARRAY3()    ' Zwischenspeicher für restliche FeldNamen
  i = 0
  For Each fld1 In tbl1.Fields
    For n = 1 To UBound(Fld_ARRAY, 1)
      If fld1.Name = Fld_ARRAY(n) Then
        ' MsgBox fld1.Name & " = " & Fld_ARRAY(n)
        GoTo WEIT4    ' Als relevantes Feld bereits im ARRAY, nächstes Feld testen
      ElseIf fld1.Name = AUTO_FLD Then
        GoTo WEIT4    ' AutoFeld wird woanders erledigt
      End If
    Next n
 
    ' Feld ist nicht im ARRAY, als Rest merken
    i = i + 1                       ' Neue Feld-Dimension
    ReDim Preserve Fld_ARRAY3(i)    ' Neue Feld-Dimension einstellen
    Fld_ARRAY3(i) = fld1.Name
    ' MsgBox i & " Restliches Feld dazu:  " & fld1.Name
WEIT4:
  Next fld1
  ANZ_RFLDs = i ' Anzahl der restlichen (nicht relevanten) Felder
  ' Alle restlichen ANZ_RFLDs Felder stehen jetzt in Fld_ARRAY3 ..........
 
  ' /////////////////////////////////////////\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  '   3. SQL-String generieren zum Erzeugen der Dummy-HilfsTabelle
  '      und die Tabelle erstellen .
  ' /////////////////////////////////////////\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  ' ''Dim F_STRG     'Ist der erste String beim Sortieren (First String..)
  ANZ_FIELDs = UBound(Fld_ARRAY, 1)
  S_TXT = "SELECT "
  For i = 1 To UBound(Fld_ARRAY, 1)
    ' NullDummy-Feld
    S_TXT = S_TXT & "'" & F_STRG & "'" & " & [" & Fld_ARRAY(i) & "] AS [ND_" & Fld_ARRAY(i) & "]" & ", "
    ' Original-Feld
    S_TXT = S_TXT & "[" & Fld_ARRAY(i) & "]" & ", "
  Next i
 
  ' --- AutoWert-Feld nicht vergessen ---------
  S_TXT = S_TXT & "[" & AUTO_FLD & "] "
 
  S_TXT = S_TXT & "INTO " & "[" & T_NAM & "_DuplikateDummy] "
  S_TXT = S_TXT & "FROM " & "[" & T_NAM & "]" & " "
 
  S_TXT = S_TXT & "ORDER BY "
  For i = 1 To UBound(Fld_ARRAY, 1)
    ' Nach NullDummy-Feldern sortieren
    ' 2006-10-22 Memo-Felder zum Sortieren umwandeln !
    For Each fld1 In tbl1.Fields
      If fld1.Name = Fld_ARRAY(i) Then
        If fld1.Type = dbMemo Then
          S_TXT = S_TXT & "'" & F_STRG & "'" & " & cvar([" & Fld_ARRAY(i) & "]), "
          Exit For
        Else
          S_TXT = S_TXT & "'" & F_STRG & "'" & " & [" & Fld_ARRAY(i) & "], "
          Exit For
        End If
      End If
    Next fld1
  Next i
  ' --- Sortieren nach Alter ----------
  If ORDER_DESC = True Then
    S_TXT = S_TXT & "[" & AUTO_FLD & "] DESC "  ' Neue Sätze oben
  Else
    S_TXT = S_TXT & "[" & AUTO_FLD & "] "       ' Neue Sätze unten
  End If
  ' MsgBox S_TXT
  DoCmd.Hourglass True
  DoCmd.SetWarnings False
  DoCmd.RunSQL S_TXT
  DoCmd.SetWarnings True
  DoCmd.Hourglass False
  ' *** Jetzt existiert eine aktuelle Dummy-Hilfs-Tabelle "..._DuplikateDummy"
 
  ' /////////////////////////////////////////\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  '    4. Duplikate-RecordSource-String generieren .
  ' /////////////////////////////////////////\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  ' S_TXT2 = "SELECT ALL "         ' 2006-10-01 Fehler ! kann keine Sätze löschen !!!!
  S_TXT2 = "SELECT DISTINCTROW "
  For i = 1 To UBound(Fld_ARRAY, 1)
    ' Nur Original-Felder:
    S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & Fld_ARRAY(i) & "]" & ", "
  Next i
  ' ****** Restliche Felder mit ausgeben ? *****
  ' MsgBox ANZ_RFLDs & "  Restliche Felder.."
  If ANZ_RFLDs > 0 And ALL_FLDs = True Then
    For i = 1 To UBound(Fld_ARRAY3, 1)
      ' MsgBox Fld_ARRAY3(i)
      S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & Fld_ARRAY3(i) & "]" & ", "
    Next i
  End If
  ' AutoFeld..
  S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & AUTO_FLD & "]" & " "
 
  S_TXT2 = S_TXT2 & "FROM " & "[" & T_NAM & "_DuplikateDummy] "
 
  S_TXT2 = S_TXT2 & "INNER JOIN " & "[" & T_NAM & "]" & " "
  S_TXT2 = S_TXT2 & "ON "
  S_TXT2 = S_TXT2 & "[" & T_NAM & "_DuplikateDummy]" & "." & "[" & AUTO_FLD & "]" & " = "
  S_TXT2 = S_TXT2 & "[" & T_NAM & "]." & "[" & AUTO_FLD & "]" & " "
  S_TXT2 = S_TXT2 & "WHERE ((("
  S_TXT2 = S_TXT2 & "[" & T_NAM & "_DuplikateDummy]" & "." & "[ND_" & Fld_ARRAY(1) & "])" & " "
  S_TXT2 = S_TXT2 & "IN (SELECT [ND_" & Fld_ARRAY(1) & "]" & " "
  S_TXT2 = S_TXT2 & "FROM " & "[" & T_NAM & "_DuplikateDummy] "
  S_TXT2 = S_TXT2 & "As Tmp GROUP BY "
  For i = 1 To UBound(Fld_ARRAY, 1)
    ' Nur Original-Felder:
    S_TXT2 = S_TXT2 & "[ND_" & Fld_ARRAY(i) & "]" & ", "
  Next i
  ' --- rechts Komma wegnehmen ! -------
  S_TXT2 = Left(S_TXT2, Len(S_TXT2) - 2)
  ' --- Leerzeichen ans Ende ! ---------
  S_TXT2 = S_TXT2 & " "
  S_TXT2 = S_TXT2 & "HAVING Count(*)>1 "
  For i = 2 To UBound(Fld_ARRAY, 1)       ' OHNE das 1. Feld !
    ' Nur Original-Felder:
    S_TXT2 = S_TXT2 & "AND [ND_" & Fld_ARRAY(i) & "]" & " = " & _
      "[" & T_NAM & "_DuplikateDummy]" & "." & "[ND_" & Fld_ARRAY(i) & "]" & " "
  Next i
  S_TXT2 = S_TXT2 & "))) "
 
  ' ----------------------- Sortierungen -------------------------------------
  S_TXT2 = S_TXT2 & "ORDER BY "
  For i = 1 To UBound(Fld_ARRAY, 1)
    ' Nur Original-Felder:
    ' 2006-10-22 Memo-Felder zum Sortieren umwandeln !
    For Each fld1 In tbl1.Fields
      If fld1.Name = Fld_ARRAY(i) Then
        If fld1.Type = dbMemo Then
          S_TXT2 = S_TXT2 & "cvar([" & T_NAM & "]" & "." & "[" & Fld_ARRAY(i) & "])" & ", "
          Exit For
        Else
          S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & Fld_ARRAY(i) & "]" & ", "
          Exit For
        End If
      End If
    Next fld1
  Next i
 
  ' '''''****** Nach restlichen Feldern auch sortieren lassen ! *****
  ' '''''MsgBox ANZ_RFLDs & "  Restliche Felder.."
  ' ''''If ANZ_RFLDs > 0 And ALL_FLDs = True Then
  ' ''''    For i = 1 To UBound(Fld_ARRAY3, 1)
  ' ''''        'MsgBox Fld_ARRAY3(i)
  ' ''''        S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & Fld_ARRAY3(i) & "]" & ", "
  ' ''''    Next i
  ' ''''End If
  ' ----- AutoFeld, Sortieren nach Alter ----------
  If ORDER_DESC = True Then
    S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & AUTO_FLD & "]" & " DESC"  ' Neue Sätze oben
  Else
    S_TXT2 = S_TXT2 & "[" & T_NAM & "]" & "." & "[" & AUTO_FLD & "]"            ' Neue Sätze unten
  End If
 
  Set rst1 = CurrentDb.OpenRecordset(S_TXT2, dbOpenSnapshot)
  Do Until rst1.EOF
    rst1.MoveNext
  Loop
  RST_COUNT = rst1.RecordCount     ' Anzahl Sätze mit zurückgeben
  rst1.Close
  Set rst1 = Nothing
 
  DuplikateRecordSourceVonTabelle = S_TXT2     ' Source-String zurückgeben
  ' MsgBox RST_COUNT & "  Sätze gefunden , Stringlänge: " & Len(S_TXT2) & vbNewLine & S_TXT2
 
  ' ''''''*** Test-Code bei Fehlern *************************************************
  ' ''''''schreibt den String in [Tab__Test_RecSource].[RecSource]
  ' ''''''(Tabelle mit Memo-Feld)
  ' ''''''Der String kann dann in eine neue Abfrage(SQL) (zzz) kopiert und getestet werden.
  ' ''''''***************************************************************************
  Set rst1 = CurrentDb.OpenRecordset("Tab__Test_RecSource", dbOpenDynaset)
  rst1.AddNew
  rst1![RecSource] = S_TXT2
  rst1.Update
  rst1.Close
  Exit Function
 
ERR_01:
  DoCmd.Hourglass False       ' 2006-08-16 (2)
  DoCmd.Echo True
  DoCmd.SetWarnings True
  MsgBox "DuplikateRecordSourceVonTabelle(T_NAM, RST_COUNT...): " & _
    vbNewLine & Err.Number & "   " & Err.Description
End Function
Public Function DuplikateRecordSourceVonTabKundenKFZ()
  Dim RC
  Dim Fld_ARRAY(7)
  Fld_ARRAY(1) = "Name"
  Fld_ARRAY(2) = "VorName"
  Fld_ARRAY(3) = "StrasseNr"
  Fld_ARRAY(4) = "PLZOrt"
  Fld_ARRAY(5) = "Telefon"
  Fld_ARRAY(6) = "Kennzeichen"
  Fld_ARRAY(7) = "KFZTyp"
 
  MsgBox RC & vbNewLine & DuplikateRecordSourceVonTabelle("TabKundenKFZ", RC, True, True, Fld_ARRAY)
End Function
Public Function DuplikateRecordSourceVonTabelleTest111()
  Dim RC
  Dim Fld_ARRAY(3)
  Fld_ARRAY(1) = "Text"
  Fld_ARRAY(2) = "Memo"
  Fld_ARRAY(3) = "Zahl"
 
  MsgBox RC & vbNewLine & DuplikateRecordSourceVonTabelle("Tab_test", RC, True)
End Function



Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
 
Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.


Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.