Tipp 0357 Doppelte Datensätze löschen (DAO)
Autor/Einsender:
Datum:
  Angie
25.04.2005 (Update)
Entwicklungsumgebung:   Excel 2000
Mit Hilfe des optionalen Parameters DISTINCT kann die Ausgabe von mehrfach vorhandenen identischen Datensätzen unterdrückt werden. Die folgende (einfache) SQL-Anweisung gibt alle Datensätze zurück, aus der alle doppelten Datensätze herausgefiltert wurden.
 
SELECT DISTINCT * FROM [Tabelle1$];
 
Sollen nur bestimmte Felder in einer neuen Tabelle ausgegeben und auf Duplikate hin überprüft werden, so könnte die SQL-Anweisung wie folgt aussehen.
 
SELECT DISTINCT Feld1, Feld2, Feld3 FROM [Tabelle1$];
 
Etwas umfangreicher wird die SQL-Anweisung, wenn man z. B. eine Kopie der Quelltabelle, jedoch ohne Duplikate, erstellen möchte, wenn die Quelltabelle auch Felder enthält, in denen keine Duplikate erlaubt sind (wie z. B. 'ID', 'Code' oder 'Nr').
Das folgende Beispiel entfernt alle Datensätze, in denen die enthaltenen Daten der Felder 'Name', 'Vorname' und 'Ort' identisch sind, und gibt, sollten identische Datensätze mehrfach vorkommen, den Datensatz mit dem kleinsten Wert im Feld 'ID' zurück. Das Ergebnis der Abfrage, eine Kopie der Quelltabelle, jedoch ohne Duplikate, wird als Abfragetabelle (QueryTable) in einem neuen Tabellenblatt ausgegeben. Eine mit DAO oder ADO erstellte Abfragetabelle kann nicht aktualisiert werden.
 
Option Explicit

Public Sub DeleteDuplicateRecordsDAO()
  Const cMsgTitle   As String = _
        "VB-fun-Demo - Doppelte Datensätze löschen (DAO)"
  Const cWksNameNew As String = "tblKunden_Neu"

  Dim objWkb        As Workbook
  Dim objWksNew     As Worksheet

  Dim dbs           As DAO.Database
  Dim rst           As DAO.Recordset

  Dim strDBName     As String
  Dim strSQL        As String

  Dim objQryTable   As QueryTable

  On Error GoTo err_DeleteRecords

  Set objWkb = ThisWorkbook

  strDBName = "c:\temp\DAOCopy" & _
            Format$(Now, "yyyymmddhhmmss") & ".xls"
  objWkb.SaveCopyAs strDBName

  Set dbs = DBEngine.OpenDatabase(strDBName, False, True, _
        "Excel 8.0;")

  strSQL = "SELECT [tblKunden$].* "
  strSQL = strSQL & "FROM [tblKunden$] "
  strSQL = strSQL & "WHERE "
  strSQL = strSQL & "EXISTS "
  strSQL = strSQL & "("
  strSQL = strSQL & "SELECT NULL "
  strSQL = strSQL & "FROM [tblKunden$] AS Tmp "
  strSQL = strSQL & "WHERE "
  strSQL = strSQL & "Tmp.[Name] = [tblKunden$].[Name] "
  strSQL = strSQL & "AND Tmp.[Vorname] = [tblKunden$].[Vorname] "
  strSQL = strSQL & "AND Tmp.[Ort] = [tblKunden$].[Ort] "
  strSQL = strSQL & "GROUP BY "
  strSQL = strSQL & "Tmp.[Name], Tmp.[Vorname], Tmp.[Ort] "
  strSQL = strSQL & "HAVING "
  strSQL = strSQL & "[tblKunden$].[ID] = MIN(Tmp.[ID])"
  strSQL = strSQL & ") "
  strSQL = strSQL & "ORDER BY [tblKunden$].[ID]"
  strSQL = strSQL & ";"

  Set rst = dbs.OpenRecordset(strSQL)

  Application.ScreenUpdating = False

  On Error Resume Next
  Application.DisplayAlerts = False
  objWkb.Worksheets(cWksNameNew).Delete
  Application.DisplayAlerts = True

  Set objWksNew = objWkb.Worksheets.Add( _
        After:=objWkb.Sheets(objWkb.Sheets.Count))
  objWksNew.Name = cWksNameNew

  Set objQryTable = objWksNew.QueryTables.Add( _
        rst, objWksNew.Range("A1"))
  objQryTable.Refresh
  Set objQryTable = Nothing

exit_Sub:
  On Error Resume Next
  Set objWksNew = Nothing
  Set objWkb = Nothing

  rst.Close
  Set rst = Nothing
  dbs.Close
  Set dbs = Nothing

  Kill strDBName

  Application.ScreenUpdating = True
  On Error GoTo 0
  Exit Sub

err_DeleteRecords:
  MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description, _
        vbOKOnly + vbCritical, cMsgTitle
  Resume exit_Sub
End Sub
 
Der Inhalt des DAO-Recordset-Objekts kann auch mit der CopyFromRecordset-Methode in das Tabellenblatt eingefügt werden. Um das selbe Ergebnis wie in obigem Beispiel zu erhalten, ist hier jedoch etwas mehr Code notwendig.
 
  Dim nFieldsCnt  As Integer
  Dim astrTmp()   As String
  Dim i As Integer

  nFieldsCnt = rst.Fields.Count

  ReDim astrTmp(nFieldsCnt)
  For i = 0 To nFieldsCnt - 1
    astrTmp(i) = rst.Fields(i).Name
  Next

  With objWksNew.Cells(1, 1).Resize(1, nFieldsCnt)
    .Value = astrTmp
    .Font.Bold = True
  End With

  objWksNew.Cells(2, 1).CopyFromRecordset rst
  objWksNew.UsedRange.Columns.AutoFit
 
Hinweis
Um diesen Tipp ausführen zu können, muss für Excel 97 die Microsoft DAO 3.51 Object Library oder die Microsoft DAO 3.6 Object Library für die Excel-Versionen ab Excel 2000 in das Projekt eingebunden werden.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (24,8 kB) Downloads bisher: [ 1035 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 27. Juni 2011