Excel

Flag Unique and Duplicate entries

Ease of Use

Easy

Version tested with

2003 

Submitted by:

Oorang

Description:

One of the most common tasks in excel is to know what data is redundant. This wil allow you to flag duplicates based on any criteria you choose. 

Discussion:

How it works: Select any combination of cells to serve as the primary key. Routine will assume that the concatenation of any selected cell within it's row is the primary key. Routine will then walk through every row in question and see if key is unique within keys selected. Features: -Will work will complex key sets (Example $E$8:$E$19,$G$3:$G$14,$J$11:$J$26) -Supports undo/redo. -Obfuscates stored setting to protect data. 

Code:

instructions for use

			

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

How to use:

  1. Open VBE by pressing Alt-F11.
  2. From the insert menu insert a standard module (will just say "Module").
  3. Paste Code
  4. Run FlagUnique Sub
  5. If you want macro to be visible in macro list (Alt-F8) menu, Option Private Module.
 

Test the code:

  1. Open attached workbook.
  2. Click Test Button.
 

Sample File:

FlagUnique.zip 648.78KB 

Approved by mdmackillop


This entry has been viewed 366 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express