VBA - Checking for Duplicates

[cwhaley1]

Hi all, I have a macro contained within a sheet in a workbook. This macro is activated when the user clicks on a shape linked to the macro. The document contains an 'approval' section to sign off the content contained within it, and the purpose of the macro is to take the user's Windows user ID and enter it into a cell, thereby acting as a unique signature. There needs to be two separate signatories, so I want the VBA code to find duplicate values, warn the user of them and then remove the second signatory until it is unique from the first. The second signature macro is separate to the first signature macro, and they run independently from one another.

The part I cannot get working is the duplicate value part. It's treating any value entered into the range of cells as duplicate, when it's been proven through testing that they're not. The range of cells in this macro are merged (C36 - C38 create one signature box, cells C39 - C41 create the other). Anybody know what's going wrong here?

Sub Approve_Change_2()

Dim ws As Worksheet
Set ws = ActiveSheet
Dim cell As Range
Dim rng As Range
Dim ees As Range
Dim myArray As Variant
Dim x As Integer

' check to see if the approver 1 fields are empty
If ActiveSheet.Range("B36, B37").Value = "" Then Exit Sub


'confirm user wants to approve
If MsgBox("Are you sure you wish to approve the change request detailed above?", vbYesNo) = vbNo Then Exit Sub

''this part of the code checks that all required fields have values in them

For Each cell In ws.Range("A11,A13,B7,B8,D6")
If cell.Value <> "" Then
            GoTo NextStep
        Else
            MsgBox "Please ensure all required fields are completed before approval is given"
            Exit Sub
        End If
    Next


NextStep:

'' cells which remain unlocked after company signatures are received are controlled in the cell properties window

ActiveSheet.Unprotect
'' this part of the code enters the approver's name (based on their Windows log on) and removes the full stop between first and last name
    ws.Range("C39").Value = Environ$("Username")
Range("C39").Select
    ActiveCell.Replace What:=".", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Cells.Find(What:=".", After:=ActiveCell, LookIn:=xlFormulas2, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
''this code enters the date the approval was made
ws.Range("D39").Value = Format(Now, "dd/mm/yyyy, hh:mm")
ActiveSheet.Protect

 'check for duplicate approver

'Look for duplicates
  Set rng = Range("C36:C41")

'Test Range for Duplicates
  If Evaluate(Replace("NOT(AND((COUNTIF(@,@)=1)))", "@", rng.Address)) = True Then
 MsgBox "Both approvers cannot be the same, please review and amend."
  Range("B39").Clear
  Range("B40").Clear
  Range("C39:C40").Value = ""
  Range("D39:D40").Value = ""
  ActiveSheet.Unprotect
  Exit Sub
    
      Else
      ActiveSheet.Protect
  End If

End Sub

 

[rlv01]

This is one of the reasons I dislike using EVALUATE. No one but the original programmer (and many times they've forgotten) can figure out what the heck is going on. In this case it is a clever but highly non-obvious hack to determine any duplicates in a range of cells. The clever hack was thwarted when someone decided to merge the cells.

Better to keep it simple and obvious.

    'check for duplicate approver

    'Look for duplicates
    Dim SigA As String, SigB As String

    SigA = Application.Trim(CStr(Range("C36").Value))    'Cells C36:C38 are merged
    SigB = Application.Trim(CStr(Range("C39").Value))    'Cells C39:C41 are merged

    If SigA = SigB Then
        MsgBox "Both approvers cannot be the same, please review and amend.", vbExclamation
        Range("C39:C41").ClearContents

        'Decide if you still want to clear the below cells
        'Range("B39").Clear
        'Range("B40").Clear
        'Range("C39:C40").Value = ""
        'Range("D39:D40").Value = ""
        ActiveSheet.Unprotect
        Exit Sub
    Else
        ActiveSheet.Protect
    End If

 

[cwhaley1]

This is one of the reasons I dislike using EVALUATE. No one but the original programmer (and many times they've forgotten) can figure out what the heck is going on. In this case it is a clever but highly non-obvious hack to determine any duplicates in a range of cells. The clever hack was thwarted when someone decided to merge the cells.

Better to keep it simple and obvious.

    'check for duplicate approver

    'Look for duplicates
    Dim SigA As String, SigB As String

    SigA = Application.Trim(CStr(Range("C36").Value))    'Cells C36:C38 are merged
    SigB = Application.Trim(CStr(Range("C39").Value))    'Cells C39:C41 are merged

    If SigA = SigB Then
        MsgBox "Both approvers cannot be the same, please review and amend.", vbExclamation
        Range("C39:C41").ClearContents

        'Decide if you still want to clear the below cells
        'Range("B39").Clear
        'Range("B40").Clear
        'Range("C39:C40").Value = ""
        'Range("D39:D40").Value = ""
        ActiveSheet.Unprotect
        Exit Sub
    Else
        ActiveSheet.Protect
    End If

Super stuff, that worked exactly as I had wanted it to. Thank you for taking the time to offer a solution.

The whole workbook was built by me and this section of code is an 'upgrade' to the approval process contained within it. Any code does contain an intro paragraph to explain what it does. Amazingly I had never - until this point - needed to check for duplicates as part of a macro and my training notes from years ago only covered it through the use of an evaluate function. Various searches on forums failed to result in anything simple which worked.