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 Dieser Tipp wurde bereits 20.693 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. |
sevAniGif (VB/VBA) Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. 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 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |