Private Function PSIDDupeCheck(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 filteredColumn As Long
Dim filterMax As Long
Dim areaCount As Long
Dim dupeRow As Long
Dim i As Long, j As Long, k As Long
Dim failReturn As String
Dim errString As String
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
Set filteredRange = .SpecialCells(xlCellTypeVisible)
With filteredRange
areaCount = .Areas.count ' 1 for headers, 1 for CG, 1 for Moved/Obstructed
Debug.Print .Address(0, 0, , True)
filterMax = CountFilteredRows(filteredRange, areaCount, sendDate)
For i = filterMax To 2 Step -1 ' Delete from bottom to avoid changing row numbers
' Look at the current PSID for any duplicate PSIDs
If Application.WorksheetFunction.CountIf(.Range("A1:A" & filterMax), _
.Range("A" & i).Value > 1) Then
dupeRow = dupeRow + 1
Debug.Print "Dupe" & i & " " & .Range("A" & i).Value
ReDim Preserve exceptArray(dupeRow - 1) ' Adjust array size up by one row
exceptArray(dupeRow - 1) = filteredRange.Range("A" & i).Value ' Record in array
' Once entered into array, write to Exceptions and delete
errString = exceptArray(dupeRow - 1) & " Duplicate PSID record"
failReturn = ProblemReport(errString, sendDate)
filteredRange.Range("A" & i).EntireRow.Delete ' Delete the dupeValue with the count of 2
End If
Next i
End With ' filteredRange
End With ' origRange
.ShowAllData
End With ' wkSheet
wkBook.Save
Application.EnableEvents = True
PSIDDupeCheck = "Success"
Else
errString = errorSrc & "Failed to open worksheet get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PSIDDupeCheck = errString
End If
Else
errString = errorSrc & "Failed to open workbook get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PSIDDupeCheck = errString
End If
wkSheet.AutoFilterMode = False
End Function
