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