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 23.316 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevEingabe 3.0 Einfach stark! Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox u.v.m. |
||||||||||||||||
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. |