Private Function DupeTest(ByRef wkBook As Workbook, _
ByRef wkSheet As Worksheet, _
ByVal wkColumn As Long, _
ByRef exceptArray() As String, _
ByRef sendDate As String, _
ByVal errorSrc As String, _
Optional ByVal param1 As String, _
Optional ByVal param2 As String, _
Optional ByVal param3 As String, _
Optional ByVal param4 As String) As String
Dim origRange As Range
Dim rowMax As Long
Dim filteredRange As Range
Dim filtSheet As Worksheet
Dim filterMax As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim fltShtName As String
Dim failReturn As String
Dim errString As String
Dim enteredVal As Boolean
fltShtName = "filtered"
enteredVal = False
wkBook.Activate ' Current active workbook is the last one prepared
If Not wkBook Is Nothing Then
Set wkSheet = wkBook.Sheets(1)
If Not wkSheet Is Nothing Then
rowMax = wkSheet.Range("A65535").End(xlUp).Row ' Assign last row
wkSheet.Range("A1:E" & rowMax).Sort _
key1:=wkSheet.Range("B1"), _
key2:=wkSheet.Range("A1")
With wkSheet
.AutoFilterMode = False
Set origRange = .Range("A1:" & param1 & rowMax)
With origRange
' Set AutoFilter to screen out non-compared objects
.AutoFilter Field:=wkColumn, Criteria1:=Array( _
param2, _
param3, _
param4), _
Operator:=xlFilterValues
.SpecialCells(xlCellTypeVisible).Copy
Set filtSheet = Sheets.Add(After:=Sheets(1))
filtSheet.Name = fltShtName
filtSheet.Paste
With filtSheet
Set filteredRange = filtSheet.UsedRange.SpecialCells(xlCellTypeVisible)
filterMax = filteredRange.Rows.count
.Range("A1:A" & filterMax).NumberFormat = "0"
With filteredRange
For i = 2 To filterMax
If Application.WorksheetFunction.CountIf(.Cells.SpecialCells(xlCellTypeVisible), _
.Range("A" & i).Value) > 1 Then
If Len(Join(exceptArray)) <= 0 Then
ReDim Preserve exceptArray(0) ' Adjust array size up by one row
exceptArray(0) = .Range("A" & i).Value ' Record in array
Else
' Check for existence in array before adding again
For k = 1 To UBound(exceptArray)
If .Range("A" & i).Value = exceptArray(k) Then
enteredVal = True
End If
Next i
If Not enteredVal Then
ReDim Preserve exceptArray(UBound(exceptArray) + 1) ' Adjust array size up by one row
exceptArray(UBound(exceptArray)) = .Range("A" & i).Value ' Record in array
End If
End If
errString = exceptArray(UBound(exceptArray)) & " Duplicate PSID record"
failReturn = ProblemReport(errString, sendDate)
End If
enteredVal = False
Next i
End With ' filteredRange
End With ' filtSheet
Application.DisplayAlerts = False ' Suppress "Delete" dialog box
Application.EnableEvents = False ' Suppress BeforeDelete event
filtSheet.Delete
Application.EnableEvents = True
Application.DisplayAlerts = True
wkSheet.ShowAllData
' Clear duplicate rows from original range
For j = UBound(exceptArray) To LBound(exceptArray) Step -1
.AutoFilter
.AutoFilter Field:=1, Criteria1:=exceptArray(j) & ".00", Operator:=xlFilterValues
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Next j
wkSheet.ShowAllData
End With ' origRange
End With ' wkSheet
Application.DisplayAlerts = False ' Suppress "SaveAs" dialog box
Application.EnableEvents = False ' Suppress BeforeSave event
wkBook.Save
Application.EnableEvents = True
Application.DisplayAlerts = True
DupeTest = "Success"
Else
errString = errorSrc & "Failed to open worksheet get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
DupeTest = errString
End If
Else
errString = errorSrc & "Failed to open workbook get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
DupeTest = errString
End If
wkSheet.AutoFilterMode = False
End Function
