vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Zippen wie die Profis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Access   |   VB-Versionen: VBA20.06.06
ACCESS 2000 Duplikate suchen und evtl. löschen

Mit diesem Code lassen sich in MS-Access Duplikate suchen und löschen, wobei die relevanten Felder angegeben werden können

Autor:   Richard MittelstädtBewertung:     [ Jetzt bewerten ]Views:  20.666 
ohne HomepageSystem:  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

Dieser Tipp wurde bereits 20.666 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.

Neue Diskussion eröffnen

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-2024 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