Excel solution
This set of prcedures will analyse the range and identify duplicate unique records.
' CHuckwick - For your purposes call the suproutine DUpStatPaste with rngIn as the consodidated list.
If you leave a blank row at the top of the list, set the Headings parameter to true.
Appended to the record set you will then see 3 columns that describe the duplicate status.
Public Sub DupStatPaste(RngIn As Range, Optional HomeCell As Range, Optional Headings As Boolean)
Dim RowCnt As Long
If IsMissing(Headings) Then
Headings = False
End If
If (IsMissing(HomeCell)) Or (HomeCell Is Nothing) Then ' assume it is the cell next to the range
Set HomeCell = RngIn.Cells(1, RngIn.Columns.Count + 1)
' Set HomeCell = RngIn.Range(Cells(RngIn.Rows.Count, RngIn.Columns.Count + 1))
End If
' Initialize integer variables for the number of rows in the array.
RowCnt = RngIn.Rows.Count
With HomeCell
If Headings Then
If HomeCell.Row <> 1 Then ' not in row 1
.Offset(-1, 0).value = "Dup 1, Unique 0"
.Offset(-1, 1).value = "Base Row"
.Offset(-1, 2).value = "Occurence"
End If
End If
ActiveSheet.Range(.Cells(1, 1), .Cells(RowCnt, 3)).value = DupArray(RngIn, True)
End With
End Sub
Function CompareRows(rngInRange As Range, iRowA As Long, iRowB As Long, iColCount As Integer) As Boolean
' will return True if the ranges are duplicates, otherwise false
CompareRows = False ' True indicates as dup row, false indicates unique row
Dim iCheckCol As Integer
With rngInRange
For iCheckCol = 1 To iColCount
If .Cells(iRowA, iCheckCol).value = .Cells(iRowB, iCheckCol).value Then
CompareRows = True
Else
CompareRows = False
Exit Function ' there is no duplicate
End If
Next ' iCheckCol
End With
End Function
Function DupArray(rngInRange As Range, Optional bResult As Boolean) As Variant
' Depending on the bResult flag :
' True return an array containing the dup/unique flag - 0 = Unique, 1= dup, _
Base row - initial row the examined row occured in _
Occur - the occurence number of the row (the number of times it is repeated)
Application.StatusBar = ""
Application.DisplayStatusBar = True
Const Duplicate = 1, Unique = 0
Dim bDupFound As Boolean
Dim lInRows As Long
Dim lInCols As Integer
Dim lRowCount As Long
Dim lRowExamine As Long
Dim lOccurCount As Long
lInCols = rngInRange.Columns.Count
lInRows = rngInRange.Rows.Count
Dim aStats() As Long
ReDim aStats(lInRows, 3)
If IsMissing(bResult) Then bResult = False ' return boolean flag only
Application.DisplayStatusBar = True
For lRowCount = 1 To lInRows
If lRowCount Mod 100 = 0 Then
Application.StatusBar = "Completed " & Int(lRowCount / lInRows * 100) & "% of duplicate analysis... "
Application.DisplayStatusBar = True
End If
lOccurCount = 2
If aStats(lRowCount, 1) <> Duplicate Then
bDupFound = False
For lRowExamine = lRowCount + 1 To lInRows
If aStats(lRowExamine, 1) <> Duplicate Then
If CompareRows(rngInRange, lRowCount, lRowExamine, lInCols) Then
If Not bResult Then ' dup found exit function with bool flag only
DupArray = Duplicate
Application.StatusBar = ""
Exit Function ' no point in continuing after first dup is found
Else
If lOccurCount = 2 Then
aStats(lRowCount, 1) = Duplicate
aStats(lRowCount, 2) = lRowCount
aStats(lRowCount, 3) = 1
End If
aStats(lRowExamine, 1) = Duplicate
aStats(lRowExamine, 2) = lRowCount
aStats(lRowExamine, 3) = lOccurCount
bDupFound = True
lOccurCount = lOccurCount + 1
End If
End If
End If
Next ' lRowExamine
If Not bDupFound Then ' no dup, mark as unique
aStats(lRowCount, 1) = Unique
aStats(lRowCount, 2) = lRowCount
aStats(lRowCount, 3) = 1 ' as the only occurence
End If
End If
Next ' lRowCount
If bResult Then
DupArray = aStats()
Else
DupArray = False ' unique
End If
Application.StatusBar = "Finished"
End Function
or
Load it into access.
run the query
Select distinct * from [The consolidated list]
The resultant recordset will be non unique.