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

  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