Tipp 0358 Doppelte Datensätze ermitteln (DAO)
Autor/Einsender:
Datum:
  Angie
25.04.2005 (Update)
Entwicklungsumgebung:   Excel 2000
Auf Basis der Ergebnisse einer Abfrage zur Duplikatsuche kann man untersuchen, ob eine Tabelle doppelte Datensätze enthält, oder ermitteln, welche Datensätze in einem oder mehreren Feldern einen gleichen Wert besitzen.
So kann man beispielsweise, wie in diesem Tipp, nach mehrfach vorkommenden Werten in den Feldern 'Name', 'Vorname' und 'Ort' suchen. Das Ergebnis der Abfrage, die alle Felder der Quelltabelle enthält, wird als Abfragetabelle (QueryTable) in einem neuen Tabellenblatt ausgegeben.
Beispiel: Wenn Ernst Müller aus Schlumpfhausen und/oder Max Mustermann aus Musterhausen mehrmals in der Quelltabelle vorkommen, werden sie in der neuen Tabelle aufgelistet.
 
Option Explicit

Public Sub GetDuplicateRecordsDAO()
  Const cMsgTitle   As String = _
        "VB-fun-Demo - Doppelte Datensätze ermitteln (DAO)"
  Const cWksNameNew As String = "tblDuplikate"

  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_GetDuplicateRecords

  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 & "("
  strSQL = strSQL & "[tblKunden$].[Name] "
  strSQL = strSQL & "IN "
  strSQL = strSQL & "("
  strSQL = strSQL & "SELECT [Name] "
  strSQL = strSQL & "FROM [tblKunden$] AS Tmp "
  strSQL = strSQL & "GROUP BY Tmp.[Name], Tmp.[Vorname], Tmp.[Ort] "
  strSQL = strSQL & "HAVING "
  strSQL = strSQL & "COUNT(*)>1 "
  strSQL = strSQL & "AND Tmp.[Vorname] = [tblKunden$].[Vorname] "
  strSQL = strSQL & "AND Tmp.[Ort] = [tblKunden$].[Ort] "
  strSQL = strSQL & ")"
  strSQL = strSQL & ") "
  strSQL = strSQL & "ORDER BY [tblKunden$].[Name],[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_GetDuplicateRecords:
  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  (23,3 kB) Downloads bisher: [ 1451 ]

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