vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Brandneu! sevEingabe v3.0 - Das Eingabecontrol der Superlative!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
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:     [ Jetzt bewerten ]Views:  20.113 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 20.113 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Aktuelle Diskussion anzeigen (1 Beitrag)

nach obenzurück


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.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel