Rubrik: Access | VB-Versionen: VBA | 06.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ädt | Bewertung: | Views: 23.274 |
ohne Homepage | System: 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