Change cell color of Duplicates with message box

I've searched through a lot of the previous posts here and have been unable to find code that will work for me. I'm a relative newbie.

I'm using Excel 2003 for a project log file that will only allow the user to type in a number that has not been "used" yet, in an effort to prevent duplicate project numbers.

I need some code that will check Column "C" starting in the second row.
Then highlight the duplicate, but not the first occurrence. There will only be numbers in column C, not including the header row.
Then pop up a message box that states the value in the message that says:
"The following number has already been taken " & cellvalue

I think that a "Worksheet_Change" type of setup might work but I'm not sure.
Nearly everything else I could find was to delete duplicates, and that's not useful for this application.

Any help is appreciated.

Thanks
Rolly

One more thing: when I said "Then highlight the duplicate, but not the first occurrence." I meant to add that I'd like the Interior color changed to red.

And also to change the Interior color back to white when the duplicate number has been changed.

Thank you,
Rolly

What are you trying to do, flag existing duplicates, or stop duplicates being added?

I'm trying to prevent duplicates from being added.

Try this and add something that deletes any row that returns "Duplicate"

Code:

---

Option Explicit
Option Base 0
Option Compare Binary
Option Private Module
 
 'Used to store registry settings.
Private Const m_strAppName_c As String = "FlagColumn"
Private Const m_strSecName_c As String = "UndoRedoSettings"
 
Private Enum eFlagColumnUndoKeys
    WorkbookName
    WorksheetName
    OutputColumn
    KeyRangeAddress
    CompareMethod
End Enum
 
Private Enum eRowType
    TopRow
    BottomRow
End Enum
 
Public Sub FlagUnique()
    '-------------------------------------------------------------------------------
    ' Procedure : FlagUnique
    ' DateTime  : 12/20/2007 11:14 AM 11:14
    ' Author    : Aaron Bush
    ' Purpose  : Scans a worksheet for duplicate/unique entries and falgs them as
    '            such.
    '-------------------------------------------------------------------------------
    Const lngRange_c As Long = 8
    Dim rng As Excel.Range
    'Get Key Range:
    On Error Resume Next
    Set rng = Excel.Application.InputBox("Select key range:", _
    "Select Key Range", Excel.Selection.address, Type:=lngRange_c)
    On Error Goto Err_Hnd
    If rng Is Nothing Then 'Detects Cancel
        Exit Sub
    End If
    Select Case VBA.MsgBox("Compare case sensitive?", vbQuestion Or _
        vbYesNoCancel Or vbDefaultButton2, "Select Comparison Method")
    Case vbYes
        FlagColumn rng, vbBinaryCompare
    Case vbNo
        FlagColumn rng, vbTextCompare
    End Select
Exit_Proc:
    On Error Resume Next
    Exit Sub
Err_Hnd:
    VBA.MsgBox "Error " & VBA.Err.Number & _
    " in procedure FlagUnique of Module mdlListManagment" & vbNewLine & _
    VBA.Err.Description, vbMsgBoxSetForeground Or vbSystemModal, _
    "Error - VBAProject.mdlListManagment.FlagUnique"
    Resume Exit_Proc
End Sub
 
Private Sub FlagColumn(ByVal keyRange As Excel.Range, compare As _
    VbCompareMethod)
    '-------------------------------------------------------------------------------
    ' Procedure : FlagColumn
    ' DateTime  : 12/20/2007 09:27 AM 09:27
    ' Author    : Aaron Bush
    ' Purpose  : Scans a worksheet for duplicate/unique entries.
    '            keyRange - The range of containing primary keys.
    '            compare  - The comparison method you wish to use.
    ' Output(s) : True  - If match found.
    '            False - If match not found or error encountered.
    '-------------------------------------------------------------------------------
    Const lngOffset_c As Long = 1
    Const strOrg_c As String = "Original"
    Const strDup_c As String = "Duplicate"
    Const strNKy_c As String = "No Key Selected"
    Const strFormat_c As String = """Working ""0.0%"
    Const lngPrecision_c As Long = 3
    Dim ws As Excel.Worksheet
    Dim wb As Excel.Workbook
    Dim cll As Excel.Range
    Dim rngCrntKey As Excel.Range
    Dim lngRow As Long
    Dim lngTopRow As Long
    Dim lngBtmRow As Long
    Dim lngOutCol As Long
    Dim strValue As String
    Dim strList() As String
    Dim lngIndx As Long
    Dim sngProg As Single
    Dim sngLstProg As Single
    On Error Goto Err_Hnd
    StandardOff
    'Get and active primary worksheet:
    Set ws = keyRange.Parent
    Set wb = ws.Parent
    Set keyRange = Excel.Intersect(keyRange, ws.UsedRange)
    'Methodology allows for nonstandardized datasets:
    lngTopRow = GetRow(TopRow, keyRange.address)
    lngBtmRow = GetRow(BottomRow, keyRange.address)
    lngOutCol = ws.UsedRange.Column + ws.UsedRange.Columns.Count
    'Save undo/redo settings:
    VBA.SaveSetting m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.WorkbookName, Obfuscate(wb.Name)
    VBA.SaveSetting m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.WorksheetName, Obfuscate(ws.Name)
    VBA.SaveSetting m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.OutputColumn, Obfuscate(CStr(lngOutCol))
    VBA.SaveSetting m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.KeyRangeAddress, Obfuscate(keyRange.address)
    VBA.SaveSetting m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.CompareMethod, Obfuscate(CStr(compare))
    'Intenionally traded off memory against the performance hit of
    'constantly redimming.
    ReDim strList(lngBtmRow - lngTopRow)
    'Loop through key range searching for duplicates.
    For lngRow = lngTopRow To lngBtmRow
        'Create unique value by concatenating all values in key range:
        strValue = vbNullString
        Set rngCrntKey = Excel.Intersect(ws.Rows(lngRow), keyRange)
        'Make sure key is found:
        If rngCrntKey Is Nothing Then
            ws.Cells(lngRow, lngOutCol).value = strNKy_c
        Else
            For Each cll In rngCrntKey.Cells
                strValue = strValue & cll.value
            Next
            'Check value for existence:
            If Exists(strValue, strList, lngIndx, compare) Then
                'Flag as duplicate.
                ws.Cells(lngRow, lngOutCol).value = strDup_c
            Else
                'Flag as original.
                ws.Cells(lngRow, lngOutCol).value = strOrg_c
                'If value not found then add to list of unique values so if it is
                'repeated it will be caught.
                strList(lngIndx) = strValue
                lngIndx = lngIndx + lngOffset_c
            End If
        End If
        'This method prevents status bar flicker:
        sngProg = VBA.Round(lngRow / lngBtmRow, lngPrecision_c)
        If sngProg <> sngLstProg Then
            sngLstProg = sngProg
            'Update status bar.
            Excel.Application.StatusBar = VBA.Format$(sngProg, strFormat_c)
        End If
    Next
    'Set undo/redo actions:
    Excel.Application.OnRepeat vbNullString, vbNullString
    Excel.Application.OnUndo "Undo Flag Duplicates", "UndoFlags"
Exit_Proc:
    On Error Resume Next
    StandardOn
    Exit Sub
Err_Hnd:
    VBA.MsgBox "Error " & VBA.Err.Number & _
    " in procedure FlagColumn of Module Module1" & vbNewLine & _
    VBA.Err.Description, vbMsgBoxSetForeground Or vbSystemModal, _
    "Error - VBAProject.Module1.FlagColumn"
    Resume Exit_Proc
    Resume
End Sub
Private Function Exists(ByRef value As String, ByRef list() As String, Optional _
    stopAt As Long, Optional compare As VbCompareMethod = _
    VbCompareMethod.vbBinaryCompare) As Boolean
    '-------------------------------------------------------------------------------
    ' Procedure : Exists
    ' DateTime  : 12/20/2007 09:09 AM 09:09
    ' Author    : Aaron Bush
    ' Purpose  : Checks to see if a value exists in an array.
    ' Input(s)  : value  - The value you want to check for.
    '            list    - The array you wish to the value for.
    '            stopAt  - Specifies a point earlier than the array upper-bound to
    '                      stop at.
    '            compare - The comparison method you wish to use.
    ' Output(s) : True  - If match found.
    '            False - If match not found or error encountered.
    '-------------------------------------------------------------------------------
    Const lngMatch_c As Long = 0
    Const lngDimensionOne_c As Long = 1
    Dim lngIndx As Long
    Dim lngValLenB As Long
    Dim blnRtrnVal As Boolean
    Dim lngUB As Long
    On Error Goto Err_Hnd
    'Get correct upperbound:
    If stopAt Then
        lngUB = stopAt
    Else
        lngUB = UBound(list, lngDimensionOne_c)
    End If
    'Store LenB of value:
    lngValLenB = VBA.LenB(value)
    For lngIndx = LBound(list) To lngUB
        'Check len first as it is far faster than a full text comparison.
        If VBA.LenB(value) = lngValLenB Then
            If VBA.StrComp(value, list(lngIndx), compare) = lngMatch_c Then
                blnRtrnVal = True
                Exit For
            End If
        End If
    Next
    Exists = blnRtrnVal
Exit_Proc:
    On Error Resume Next
    'Place Holder
    Exit Function
Err_Hnd:
    VBA.MsgBox "Error " & VBA.Err.Number & _
    " in procedure Exists of Module mdlListManagment" & vbNewLine & _
    VBA.Err.Description, vbMsgBoxSetForeground Or vbSystemModal, _
    "Error - VBAProject.mdlListManagment.Exists"
    Resume Exit_Proc
    Resume
End Function
Public Sub UndoFlags()
    '-------------------------------------------------------------------------------
    ' Procedure : UndoFlags
    ' DateTime  : 12/20/2007 11:07 AM 11:07
    ' Author    : Aaron Bush
    ' Purpose  : To remove the effects of the Flag Unique Procedure.
    '-------------------------------------------------------------------------------
    Const strFail_c As String = "Fail"
    Dim lngCol As Long
    Dim ws As Excel.Worksheet
    Dim wb As Excel.Workbook
    On Error Goto Err_Hnd
    StandardOff
    'Get output column from registry:
    Set wb = Excel.Workbooks(Obfuscate(VBA.GetSetting(m_strAppName_c, _
    m_strSecName_c, eFlagColumnUndoKeys.WorkbookName, strFail_c)))
    Set ws = wb.Worksheets(Obfuscate(VBA.GetSetting(m_strAppName_c, _
    m_strSecName_c, eFlagColumnUndoKeys.WorksheetName, strFail_c)))
    lngCol = Obfuscate(VBA.GetSetting(m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.OutputColumn, strFail_c))
    'Remove output column:
    ws.Columns(lngCol).Delete
    Excel.Application.OnRepeat "Redo Flag Duplicates", "RepeatFlags"
Exit_Proc:
    On Error Resume Next
    StandardOn
    Exit Sub
Err_Hnd:
    VBA.MsgBox "Undo attempt failed", vbInformation Or vbMsgBoxSetForeground, _
    "Operation Cannot be Undone."
    Resume Exit_Proc
End Sub
Public Sub RepeatFlags()
    '-------------------------------------------------------------------------------
    ' Procedure : RepeatFlags
    ' DateTime  : 12/20/2007 11:07 AM 11:07
    ' Author    : Aaron Bush
    ' Purpose  : To repeat the effects of the Flag Unique Procedure.
    '-------------------------------------------------------------------------------
    Const strFail_c As String = "Fail"
    Dim ws As Excel.Worksheet
    Dim wb As Excel.Workbook
    Dim rng As Excel.Range
    Dim compare As VbCompareMethod
    On Error Goto Err_Hnd
    StandardOff
    'Get output column from registry:
    Set wb = Excel.Workbooks(Obfuscate(VBA.GetSetting(m_strAppName_c, _
    m_strSecName_c, eFlagColumnUndoKeys.WorkbookName, strFail_c)))
    Set ws = wb.Worksheets(Obfuscate(VBA.GetSetting(m_strAppName_c, _
    m_strSecName_c, eFlagColumnUndoKeys.WorksheetName, strFail_c)))
    Set rng = ws.Range(Obfuscate(VBA.GetSetting(m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.KeyRangeAddress, strFail_c)))
    compare = Obfuscate(VBA.GetSetting(m_strAppName_c, m_strSecName_c, _
    eFlagColumnUndoKeys.CompareMethod, strFail_c))
    FlagColumn rng, compare
Exit_Proc:
    On Error Resume Next
    StandardOn
    Exit Sub
Err_Hnd:
    VBA.MsgBox "Repeat attempt failed", vbInformation Or vbMsgBoxSetForeground, _
    "Operation Cannot be Undone."
    Resume Exit_Proc
End Sub
 
Private Sub StandardOff()
    On Error Resume Next
    With Excel.Application
        .Cursor = xlWait
        .StatusBar = "Working..."
        .EnableCancelKey = xlErrorHandler
        .ScreenUpdating = False
        .EnableEvents = False
    End With
End Sub
 
Private Sub StandardOn()
    On Error Resume Next
    With Excel.Application
        .Cursor = xlDefault
        .StatusBar = False
        .EnableCancelKey = xlInterrupt
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Private Function Obfuscate(value As String) As String
    '-------------------------------------------------------------------------------
    ' Procedure : Obfuscate
    ' DateTime  : 12/20/2007 12:04 PM 12:04
    ' Author    : Aaron Bush
    ' Purpose  : Used to prevent values from being obviously readable.
    ' Input(s)  : value - The value to Obfuscate.
    ' Output(s) : The Obfuscated/Unobfuscated value (see remarks).
    ' Remarks  : Should not be considered "secure" used only to obfuscate.
    '            To Unobfuscate a value simply run the obfuscated value back
    '            through this sub and the result will be the clear text.
    '-------------------------------------------------------------------------------
    Const lngLB_c As Long = 0
    Dim strKey As String
    Dim bytVal() As Byte
    Dim bytKey() As Byte
    Dim lngValLen As Long
    Dim lngIndx As Long
    On Error Goto Err_Hnd
    lngValLen = VBA.Len(value)
    bytVal = value
    strKey = VBA.Environ$("COMPUTERNAME")
    Do
        strKey = strKey & strKey
    Loop Until VBA.Len(strKey) > lngValLen
    strKey = VBA.Right$(strKey, lngValLen)
    bytKey = strKey
    For lngIndx = lngLB_c To UBound(bytVal)
        bytVal(lngIndx) = bytVal(lngIndx) Xor bytKey(lngIndx)
    Next
    Obfuscate = CStr(bytVal)
Exit_Proc:
    On Error Resume Next
    Exit Function
Err_Hnd:
    VBA.MsgBox "Error " & VBA.Err.Number & _
    " in procedure Obfuscate of Module mdlListManagment" & vbNewLine & _
    VBA.Err.Description, vbMsgBoxSetForeground Or vbSystemModal, _
    "Error - VBAProject.mdlListManagment.Obfuscate"
    Resume Exit_Proc
End Function
 
Private Function GetRow(rowType As eRowType, ByVal address As String) As Long
    '-------------------------------------------------------------------------------
    ' Procedure : GetTopRow
    ' DateTime  : 12/20/2007 01:13 PM 13:13
    ' Author    : Aaron Bush
    ' Purpose  : Retrieves the top or bottom row of a complex range.
    ' Input(s)  : Address of range you want the row of.
    ' Output(s) : Row number
    '-------------------------------------------------------------------------------
    Const lngLB_c As Long = 1
    Const lngZero_c As Long = 0
    Dim strRows() As String
    Dim lngIndx As Long
    Dim lngCrnt As Long
    Dim lngRtn As Long
    address = Strip(address)
    strRows = VBA.Split(address, ",")
    lngRtn = strRows(lngZero_c)
    If rowType = TopRow Then
        For lngIndx = lngLB_c To UBound(strRows)
            lngCrnt = CLng(strRows(lngIndx))
            If lngCrnt < lngRtn Then
                lngRtn = lngCrnt
            End If
        Next
    ElseIf rowType = BottomRow Then
        For lngIndx = lngLB_c To UBound(strRows)
            lngCrnt = CLng(strRows(lngIndx))
            If lngCrnt > lngRtn Then
                lngRtn = lngCrnt
            End If
        Next
    End If
    GetRow = lngRtn
End Function
 
Private Function Strip(ByVal value As String) As String
    Const lngOffset_c As Long = 1
    Const lngUnicodeStep_c As Long = 2
    Const lngLB_c As Long = 0
    Const lngDlr_c As Long = 36
    Const lngCln_c As Long = 58
    Const lngCma_c As Long = 44
    Dim lngUprBndValue As Long
    Dim bytValue() As Byte
    Dim bytReturn() As Byte
    Dim lngIndx1 As Long
    Dim lngIndx2 As Long
    bytValue = UCase$(value)
    lngUprBndValue = UBound(bytValue)
    ReDim bytReturn(lngUprBndValue)
    For lngIndx1 = lngLB_c To lngUprBndValue Step lngUnicodeStep_c
        If bytValue(lngIndx1) <> lngDlr_c Then
            If bytValue(lngIndx1) = lngCln_c Then
                bytReturn(lngIndx2) = lngCma_c
                lngIndx2 = lngIndx2 + lngUnicodeStep_c
            ElseIf bytValue(lngIndx1) < vbKeyA Then
                bytReturn(lngIndx2) = bytValue(lngIndx1)
                lngIndx2 = lngIndx2 + lngUnicodeStep_c
            ElseIf bytValue(lngIndx1) > vbKeyZ Then
                bytReturn(lngIndx2) = bytValue(lngIndx1)
                lngIndx2 = lngIndx2 + lngUnicodeStep_c
            End If
        End If
    Next
    ReDim Preserve bytReturn(lngIndx2 - lngOffset_c)
    Strip = CStr(bytReturn)
End Function

---

Thanks for your help, I tried it and the following error appeared:
"Compile Error:"
"User-defined type not defined."

I rechecked it and found that it didn't completely copy over, after I recopied it and verified everything had copied over I get this error:
"Compile Error:"
"Ambiguous name detected:FlagUnique"

which part of the script did it highlight?

The two spaces directly above the "Pu" of Public in the following line:

Public Sub FlagUnique()

Try getting original file via link http://www.vbaexpress.com/kb/default...n=13&kb_id=985