Option Explicit
Option Base 0
Option Compare Binary
Option Private Module
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()
Const lngRange_c As Long = 8
Dim rng As Excel.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
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)
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
Set ws = keyRange.Parent
Set wb = ws.Parent
Set keyRange = Excel.Intersect(keyRange, ws.UsedRange)
lngTopRow = GetRow(TopRow, keyRange.address)
lngBtmRow = GetRow(BottomRow, keyRange.address)
lngOutCol = ws.UsedRange.Column + ws.UsedRange.Columns.Count
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))
ReDim strList(lngBtmRow - lngTopRow)
For lngRow = lngTopRow To lngBtmRow
strValue = vbNullString
Set rngCrntKey = Excel.Intersect(ws.Rows(lngRow), keyRange)
If rngCrntKey Is Nothing Then
ws.Cells(lngRow, lngOutCol).value = strNKy_c
Else
For Each cll In rngCrntKey.Cells
strValue = strValue & cll.value
Next
If Exists(strValue, strList, lngIndx, compare) Then
ws.Cells(lngRow, lngOutCol).value = strDup_c
Else
ws.Cells(lngRow, lngOutCol).value = strOrg_c
strList(lngIndx) = strValue
lngIndx = lngIndx + lngOffset_c
End If
End If
sngProg = VBA.Round(lngRow / lngBtmRow, lngPrecision_c)
If sngProg <> sngLstProg Then
sngLstProg = sngProg
Excel.Application.StatusBar = VBA.Format$(sngProg, strFormat_c)
End If
Next
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
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
If stopAt Then
lngUB = stopAt
Else
lngUB = UBound(list, lngDimensionOne_c)
End If
lngValLenB = VBA.LenB(value)
For lngIndx = LBound(list) To lngUB
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
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()
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
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))
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()
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
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
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
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
|