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
Change cell color of Duplicates with message box
Reply With Quote
