| Rubrik: Access | VB-Versionen: VBA | 20.06.06 |
 ACCESS 2000 Duplikate suchen und evtl. löschenMit diesem Code lassen sich in MS-Access Duplikate suchen und löschen, wobei die relevanten Felder angegeben werden können | ||
Autor:  Richard Mittelstädt | Bewertung:   | Views: 20.693 |
| ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 |  Beispielprojekt auf CD |
Mit nachfolgendem Code lassen sich in MS-Access 2000 Duplikate suchen und löschen, wobei die relevanten Felder angegeben werden können.
Option Compare Database Option Explicit Public Function DuplikateLoeschenVonTabelleFelder( _ T_NAM, _ USE_NZ As Boolean, _ Optional DEL_New_RECs As Boolean = False, _ Optional Fld_ARRAY) ' ********************************************************************************* ' Funktion sucht und löscht nach Bestätigung Duplikate in einer Tabelle. ' (AUCH LEERE Duplikate !!! ) ' -------------- Parameter ----------------------------------------------- ' T_NAM Tabellen-Name ' USE_NZ Nz-Funktion benutzen 2006-08-15 ' Bewertung von Null-Werten u. Leer-Einträgen : ' True -> Null-Wert IsNull() = Leer-Eintrag "" ' False -> Null-Wert IsNull() <> Leer-Eintrag "" ' ' DEL_New_RECs Neuere oder ältere Sätze löschen ? 2006-09-02 ' (Nur wirksam, wenn Tabelle ein Auto-Feld hat ! ) ' True -> Neuere löschen (ÄLTESTER bleibt erhalten.) ' Standard-Wert-> False -> Ältere löschen (NEUESTER bleibt erhalten.) ' ' 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. Prüfen und anzeigen, welche Felder untersucht wurden und ' ob und wieviele Duplikate vorhanden sind. ' -Dabei wird der Source-String des Duplikate-FINDEN-RecordSets ' aus den angegebenen bzw. aus allen (relevanten) Feldern gebildet. ' 3. Wenn Duplikate vorhanden sind, kann das Löschen gestartet werden. ' -Vor dem Löschen wird eine (weitere) Sicherung der Tabelle angelegt. ' (siehe Funktion "TabelleSichern(T_NAM)" ) ' -Das Duplikate-LÖSCHEN-RecordSet ist (NEU 2006-09-01) nur ein Teil ' der Tabelle! und enthält NUR Datensätze, ' die zu einem einzelnen Duplikaten gehören. ' (sortiert nach allen relevanten Feldern ! ) ' Falls die Tabelle ein Auto-Wert-Feld hat, wird zusätzlich auch noch ' nach diesem (entspr. der Option DEL_New_RECs ) sortiert, um später ' den jeweils neuesten bzw. ältesten Satz des Duplikates zu belassen . ' 4. ENDE- bzw. Resultat- Meldung ' ********************************************************************************* Dim tbl1 As TableDef Dim fld1 As Field, fld2 As Field, fld3 As Field Dim rst1 As Recordset, rst2 As Recordset Dim S_TXT ' Source-Text für Duplikate-FINDEN!-Recordset ' (Duplikate und deren Anzahl) Dim S_TXT2 ' Source-Text für Duplikate-Löschen-Recordset ' (Alle Sätze der Tabelle sortiert! nach Feldern und evtl. Auto-Feld) Dim i, n Dim ANZ_FIELDs ' Anzahl zu untersuchender Tabellen-Felder Dim AUTO_FLD ' Evtl. vorhandenes Autowert-Feld Dim D_GEF ' Merken Aktuell gilt noch "Duplikat gefunden" Dim ANZ_DUPL ' Anzahl aktueller Satz-Duplikate Dim t1, t2, t3, t4, t5, t6, t7, t8, t9, t20, X 'Texte Dim z ' Anzahl der Löschungen Dim Y ' TabellenSicherung (Rückgabe-Wert) ' On Error GoTo ERR_01 ' ***** 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 DoCmd.Hourglass True WEIT1: ' **** Keine Felder angegeben ?, dann alle Felder vergleichen ******* If IsMissing(Fld_ARRAY) Then ' MsgBox tbl1.Fields.Count Dim Fld_ARRAY2() ' Zwischenspeicher für relevante FeldNamen 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 WEIT2 ' Ole If fld1.Type = dbLong And fld1.Attributes = 17 Then GoTo WEIT2 ' Auto-Inkr/-Zufall If fld1.Type = dbGUID Then GoTo WEIT2 ' Auto Repl. ID i = i + 1 ' Neue Feld-Dimension ReDim Preserve Fld_ARRAY2(i) ' Neue Feld-Dimension einstellen Fld_ARRAY2(i) = fld1.Name WEIT2: Next fld1 Fld_ARRAY = Fld_ARRAY2 End If ' *** Source-String für Recordset bilden ************************************** ANZ_FIELDs = UBound(Fld_ARRAY, 1) S_TXT = "SELECT " For i = 1 To UBound(Fld_ARRAY, 1) S_TXT = S_TXT & "First(" & Fld_ARRAY(i) & ") AS [" & Fld_ARRAY(i) & " Feld], " Next i S_TXT = S_TXT & "Count(" & "*" & ") AS AnzahlVonDuplikaten " S_TXT = S_TXT & "FROM " & T_NAM & " " S_TXT = S_TXT & "GROUP BY " For i = 1 To UBound(Fld_ARRAY, 1) If USE_NZ = True Then S_TXT = S_TXT & "Nz(" & Fld_ARRAY(i) & ")" & ", " ' 2006-08-15 Nz... Else S_TXT = S_TXT & Fld_ARRAY(i) & ", " End If Next i ' --- rechts Komma wegnehmen ! ------- S_TXT = Left(S_TXT, Len(S_TXT) - 2) ' --- Leerzeichen ans Ende ! --------- S_TXT = S_TXT & " " S_TXT = S_TXT & "HAVING " S_TXT = S_TXT & "(((Count(nz(" & Fld_ARRAY(1) & ")))>1) AND ((Count(nz(" & Fld_ARRAY(ANZ_FIELDs) & ")))>1)) " ' MsgBox S_TXT Set rst1 = CurrentDb.OpenRecordset(S_TXT, dbOpenSnapshot) ' in rst1 stehen jetzt alle Duplikate mit und für die relevante(n) Felder ' und als "AnzahlVonDuplikaten" die Anzahl dieser Datensätze. 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 Exit For End If Next fld1 Do Until rst1.EOF rst1.MoveNext Loop n = rst1.RecordCount rst1.Close Set rst1 = Nothing DoCmd.Hourglass False t1 = "-------- Duplikate in Tabelle " & Chr(34) & T_NAM & Chr(34) & " ------------" t1 = t1 & vbNewLine & vbNewLine t2 = "Folgende Felder wurden verglichen:" & vbNewLine For i = 1 To UBound(Fld_ARRAY, 1) t3 = t3 & " " & Fld_ARRAY(i) & vbNewLine Next i t3 = t3 & vbNewLine t4 = n & " Mehrfach vorhandene Datensätze wurden gefunden." & vbNewLine If USE_NZ = True Then t5 = "(Null-Werte und Leer-Einträge wurden als GLEICH bewertet.)" Else t5 = "(Null-Werte und Leer-Einträge wurden als VERSCHIEDEN bewertet.)" End If t5 = t5 & vbNewLine & vbNewLine t6 = " Sollen die überflüssigen Duplikate dieser " & n & " Sätze" & vbNewLine t7 = " jetzt gelöscht werden ?" & vbNewLine & vbNewLine If Not AUTO_FLD = "" Then If Not AUTO_FLD = "" Then ' DEL_New_RECs Neuere oder ältere Sätze löschen ? 2006-09-02 If DEL_New_RECs = True Then ' Aufwärts-> Untere Neuere Sätze löschen '2006-09-03 t8 = "(Der jeweils ÄLTESTE Datensatz bleibt erhalten entpr. Feld " & _ Chr(34) & AUTO_FLD & Chr(34) & ")" & vbNewLine Else ' Abwärts-> Untere Ältere Sätze löschen '2006-09-03 t8 = "(Der jeweils NEUESTE Datensatz bleibt erhalten entpr. Feld " & _ Chr(34) & AUTO_FLD & Chr(34) & ")" & vbNewLine End If End If End If t9 = "(Tabelle " & Chr(34) & T_NAM & Chr(34) & " wird gesichert !)" & vbNewLine If n = 0 Then t4 = "Es wurden KEINE mehrfach vorkommenden Sätze gefunden." & vbNewLine t20 = t1 & t2 & t3 & t4 & t5 X = MsgBox(t20, vbInformation + vbOKOnly, "Keine Duplikate ...") Exit Function End If t20 = t1 & t2 & t3 & t4 & t5 & t6 & t7 & t8 & t9 X = MsgBox(t20, vbQuestion + vbOK + vbDefaultButton2, "Duplikate löschen...") 'vbOK=OK_Abbrechen If Not X = vbOK Then Exit Function End If ' **** Vor der Bearbeitung Tabellen-Sicherung anlegen ***************** DoCmd.Hourglass True Y = TabelleSichern(T_NAM) DoCmd.Hourglass False If Y = Null Then MsgBox "Tabelle " & Chr(34) & T_NAM & Chr(34) & " konnte nicht gesichert werden !", _ vbCritical, "Fehler bei Tabellensicherung..." Exit Function End If ' ********************* SUCHEN und richtige Anzahl LÖSCHEN ! *************** DoCmd.Hourglass True Set rst1 = CurrentDb.OpenRecordset(S_TXT, dbOpenSnapshot) ' Duplikate und deren Anzahl z = 0 ' Anzahl Löschungen Do Until rst1.EOF D_GEF = False ' 2008-09-02 RecordSet mit dem zu bearbeitenenden Duplikat bilden **************** ' Source für jedes einzelne Duplikat extra bilden (nicht die ganze Tabelle nehmen ! S_TXT2 = "SELECT * FROM [" & T_NAM & "] " & _ "WHERE " For i = 1 To UBound(Fld_ARRAY, 1) If i > 1 Then S_TXT2 = S_TXT2 & "AND " 'AND NICHT für 1. Bedingung End If If USE_NZ = True Then S_TXT2 = S_TXT2 & "Nz([" & Fld_ARRAY(i) & "]) = Nz(" & "'" & rst1.Fields(Fld_ARRAY(i) & " Feld") & "'" & ") " Else ' S_TXT2 = S_TXT2 & "[" & Fld_ARRAY(i) & "] = " & "'" & rst1.Fields(Fld_ARRAY(i) & " Feld") & "'" & " " S_TXT2 = S_TXT2 & "Nz([" & Fld_ARRAY(i) & "]) = " & "'" & rst1.Fields(Fld_ARRAY(i) & " Feld") & "'" & " " End If Next i ' **** Sortierung über alle relevanten Felder : S_TXT2 = S_TXT2 & "ORDER BY " For i = 1 To UBound(Fld_ARRAY, 1) If i > 1 Then S_TXT2 = S_TXT2 & ", " End If If USE_NZ = True Then S_TXT2 = S_TXT2 & "Nz([" & Fld_ARRAY(i) & "])" ' 2006-08-15 Nz... Else S_TXT2 = S_TXT2 & "[" & Fld_ARRAY(i) & "]" End If Next i If Not AUTO_FLD = "" Then ' DEL_New_RECs Neuere oder ältere Sätze löschen ? 2006-09-02 If DEL_New_RECs = True Then S_TXT2 = S_TXT2 & ", [" & AUTO_FLD & "] ASC" ' Aufwärts-> Untere Neuere Sätze löschen Else S_TXT2 = S_TXT2 & ", [" & AUTO_FLD & "] DESC" ' Abwärts-> Untere Ältere Sätze löschen End If End If Set rst2 = CurrentDb.OpenRecordset(S_TXT2, dbOpenDynaset) ' Muss hier neu gesetzt werden ! Do Until rst2.EOF For Each fld1 In rst1.Fields If Not fld1.Name = "AnzahlVonDuplikaten" Then For Each fld2 In rst2.Fields If fld1.Name = fld2.Name & " Feld" Then If fld1 = fld2 Then D_GEF = True ' ElseIf Nz(fld1, 0) = Nz(fld2, 0) Then ' geändert 2006-08-15 Nz... : ElseIf Nz(fld1) = Nz(fld2) And USE_NZ = True Then D_GEF = True ElseIf IsNull(fld1) And IsNull(fld2) Then D_GEF = True ElseIf IsEmpty(fld1) And IsEmpty(fld2) Then D_GEF = True ElseIf CVar(fld1) = CVar(fld2) Then D_GEF = True Else D_GEF = False GoTo WEIT3 ' zum nächsten Satz des Duplikats End If GoTo WEIT4 ' nächstes Feld des Duplikats End If Next fld2 End If WEIT4: Next fld1 If D_GEF = True Then ' *** Löschen !!!! *********************** ' Steht jetzt auf ERSTEM Satz der insgesamt ANZ_DUPL Duplikate ANZ_DUPL = rst1![AnzahlVonDuplikaten] ' Anzahl Sätze Dieses Duplikats For n = 1 To ANZ_DUPL - 1 rst2.MoveNext ' diesen ERSTEN (=neuesten) Satz lassen ' bzw. diesen gerade gelöschten verlassen ' einfach auf den nächsten Satz zum : rst2.Delete ' <------ Löschen ! z = z + 1 Next n D_GEF = False End If WEIT3: rst2.MoveNext ' nächster Satz des Duplikats Loop rst1.MoveNext ' Nächste Duplikate- "Gruppe" Loop rst1.Close ' 2006-08-16 "freimachen ?" Set rst1 = Nothing rst2.Close Set rst2 = Nothing DoCmd.Hourglass False If z = 1 Then t1 = "Es wurde 1 Datensatz gelöscht." & vbNewLine & vbNewLine Else t1 = "Es wurden " & z & " Datensätze gelöscht." & vbNewLine & vbNewLine End If t2 = "Tabelle " & Chr(34) & T_NAM & Chr(34) & " wurde gesichert nach:" & vbNewLine t3 = " " & Y & vbNewLine MsgBox t1 & t2 & t3, vbInformation, "OK..." Exit Function ERR_01: DoCmd.Hourglass False ' 2006-08-16 (2) DoCmd.Echo True MsgBox "DuplikateLoeschenVonTabelleFelder(T_NAM, USE_NZ...): " & _ vbNewLine & Err.Number & " " & Err.Description End Function Public Function DuplikateLoeschenTest111() Dim Fld_ARRAY(3) Fld_ARRAY(1) = "Text" Fld_ARRAY(2) = "Memo" Fld_ARRAY(3) = "Zahl" ' Call DuplikateLoeschenVonTabelleFelder("Tab_test", True, , Fld_ARRAY) Call DuplikateLoeschenVonTabelleFelder("Tab_test", True) End Function
Public Function TabelleSichern(T_NAM) ' ********************************************************* ' Funktion legt max. ' T_SICH Sicherungen ' T_NAM & "_Sicherung_nn (nn = 01...99) ' der Tabelle ' T_NAM an. ' ********************************************************* Dim tbl1 As TableDef, i Dim T_SICH ' ------------------------------ T_SICH = 5 ' 5 Sicherungen halten ! ' ------------------------------ TabelleSichern = Null For Each tbl1 In CurrentDb.TableDefs If tbl1.Name = T_NAM Then GoTo WEIT1 End If Next tbl1 DoCmd.Hourglass False MsgBox "Tabelle " & Chr(34) & T_NAM & Chr(34) & " existiert nicht !" Exit Function WEIT1: ' **** Sicherung 01 löschen ******** For Each tbl1 In CurrentDb.TableDefs If tbl1.Name = T_NAM & "_Sicherung_01" Then DoCmd.SetWarnings False DoCmd.DeleteObject acTable, T_NAM & "_Sicherung_01" DoCmd.SetWarnings True End If Next tbl1 ' **** Sicherungen Umbenennen 02 -> 01, 03 -> 02, ... T_SICH -> T_SICH -1 ************ For i = 2 To T_SICH For Each tbl1 In CurrentDb.TableDefs If tbl1.Name = T_NAM & "_Sicherung_" & Format(i, "00") Then DoCmd.Rename T_NAM & "_Sicherung_" & Format(i - 1, "00"), acTable, T_NAM & "_Sicherung_" & Format(i, "00") End If Next tbl1 Next i ' **** Neue (höchste) Sicherung auf _Sicherung_<T_SICH> ******* DoCmd.CopyObject , T_NAM & "_Sicherung_" & Format(T_SICH, "00"), acTable, T_NAM TabelleSichern = T_NAM & "_Sicherung_" & Format(T_SICH, "00") End Function
Public Function TestTabSich0002(Optional DEL_New_RECs As Boolean = False) ' Call TabelleSichern("Tab_test") End Function
Public Function TestTabSich0003() Call TestTabSich0002(True) End Function
Public Function Auf_Leerstring_Setzen() On Error GoTo ERR_01 Dim t1, t2, t3, t4, X Dim ctl1 As Control Set ctl1 = Screen.ActiveControl t1 = ctl1.Name & " auf Leer-String " & Chr(34) & Chr(34) & " setzen ?" & vbNewLine & vbNewLine t2 = " Ja " & ctl1.Name & " --> " & Chr(34) & Chr(34) & vbNewLine t3 = " Nein " & ctl1.Name & " --> Null" & vbNewLine & vbNewLine X = MsgBox(t1 & t2 & t3, vbQuestion + vbYesNoCancel + vbDefaultButton3, "") Select Case X Case vbYes ctl1 = "" Case vbNo ctl1 = Null Case Else ' End Select DoCmd.RunCommand acCmdSaveRecord ' Satz speichern ,falls Cursor noch drin... Exit Function ERR_01: Select Case Err.Number Case 3329 MsgBox Err.Number & vbNewLine & "Gelöschter Satz !..." Case Else MsgBox "Auf_Leerstring_Setzen(): " & Err.Number & " " & Err.Description End Select End Function
Public Function DuplikateAnzahlVonTabelleFelder(T_NAM, USE_NZ As Boolean, Optional Fld_ARRAY) ' ********************************************************************************* ' Funktion ermittelt Duplikate-Anzahl für übergebene relevante Felder in einer Tabelle. ' Ermittelt wird die Anzahl von Datensätzen, die mehrfach vorkommen: ' Wird zB. 3 ermittelt, dann kann zB.: ' - das 1. Duplikat 2x vorkommen ' - das 2. Duplikat 7x vorkommen ' - das 1. Duplikat 3x vorkommen ' ' -------------- Parameter ----------------------------------------------- ' T_NAM 'Tabellen-Name ' USE_NZ 'Nz-Funktion benutzen ' 2006-08-15 Bewrtung von Null-Werten u. Leer-Einträgen : ' ' True -> Null-Wert IsNull() = Leer-Eintrag "" ' False -> Null-Wert IsNull() <> Leer-Eintrag "" ' ' 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. Prüfen, ob und wieviele Duplikate vorhanden sind. ' -Dabei wird der Source-String des Duplikate-FINDEN-RecordSets ' aus den angegebenen bzw. aus allen (relevanten) Feldern gebildet. ' ' * ******************************************************************************** Dim tbl1 As TableDef Dim fld1 As Field, fld2 As Field, fld3 As Field Dim rst1 As Recordset Dim S_TXT ' Source-Text für Duplikate-FINDEN!-Recordset ' (Duplikate und deren Anzahl) Dim S_TXT2 ' Source-Text für Duplikate-Löschen-Recordset ' (Alle Sätze der Tabelle sortiert! nach Feldern und evtl. Auto-Feld) Dim i, n Dim ANZ_FIELDs ' Anzahl zu untersuchender Tabellen-Felder Dim AUTO_FLD ' Evtl. vorhandenes Autowert-Feld Dim D_GEF ' Merken Aktuell gilt noch "Duplikat gefunden" Dim ANZ_DUPL ' Anzahl aktueller Satz-Duplikate Dim t1, t2, t3, t4, t5, t6, t7, t8, t20, X 'Texte ' ***** 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 fehlt..." Exit Function DoCmd.Hourglass True WEIT1: ' **** Keine Felder angegeben ?, dann alle Felder vergleichen ******* If IsMissing(Fld_ARRAY) Then ' MsgBox tbl1.Fields.Count Dim Fld_ARRAY2() ' Zwischenspeichern der relevanten FeldNamen 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 WEIT2 ' Ole If fld1.Type = dbLong And fld1.Attributes = 17 Then GoTo WEIT2 ' Auto-Inkr/-Zufall If fld1.Type = dbGUID Then GoTo WEIT2 ' Auto Repl. ID i = i + 1 ' Neue Feld-Dimension ReDim Preserve Fld_ARRAY2(i) ' Neue Feld-Dimension einstellen Fld_ARRAY2(i) = fld1.Name WEIT2: Next fld1 Fld_ARRAY = Fld_ARRAY2 End If ' *** Source-String für Recordset bilden ************************************** ANZ_FIELDs = UBound(Fld_ARRAY, 1) S_TXT = "SELECT " For i = 1 To UBound(Fld_ARRAY, 1) S_TXT = S_TXT & "First(" & Fld_ARRAY(i) & ") AS [" & Fld_ARRAY(i) & " Feld], " Next i S_TXT = S_TXT & "Count(" & "*" & ") AS AnzahlVonDuplikaten " S_TXT = S_TXT & "FROM " & T_NAM & " " S_TXT = S_TXT & "GROUP BY " For i = 1 To UBound(Fld_ARRAY, 1) If USE_NZ = True Then S_TXT = S_TXT & "Nz(" & Fld_ARRAY(i) & ")" & ", " ' 2006-08-15 Nz... Else S_TXT = S_TXT & Fld_ARRAY(i) & ", " End If Next i ' --- rechts Komma wegnehmen ! ------- S_TXT = Left(S_TXT, Len(S_TXT) - 2) ' --- Leerzeichen ans Ende ! --------- S_TXT = S_TXT & " " S_TXT = S_TXT & "HAVING " S_TXT = S_TXT & "(((Count(nz(" & Fld_ARRAY(1) & ")))>1) AND ((Count(nz(" & Fld_ARRAY(ANZ_FIELDs) & ")))>1)) " ' MsgBox S_TXT Set rst1 = CurrentDb.OpenRecordset(S_TXT, dbOpenSnapshot) ' in rst1 stehen jetzt alle Duplikate mit und für die relevante(n) Felder ' und als "AnzahlVonDuplikaten" die Anzahl dieser Datensätze. 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 Exit For End If Next fld1 Do Until rst1.EOF rst1.MoveNext Loop n = rst1.RecordCount rst1.Close Set rst1 = Nothing DoCmd.Hourglass False DuplikateAnzahlVonTabelleFelder = n End Function
Public Function DuplikateAnzahlTab_test_3x() Dim Fld_ARRAY(3) Fld_ARRAY(1) = "Text" Fld_ARRAY(2) = "Memo" Fld_ARRAY(3) = "Zahl" MsgBox DuplikateAnzahlVonTabelleFelder("Tab_test", True, Fld_ARRAY) End Function
