Option Explicit
Public sGblCurrentNameInColumnF As String
Public sGblCurrentNameInColumnG As String
Sub CreateDataValidationForOneNameController(ByRef Target As Range)
'This controls 'Data Validation' when one cell changes in Column 'F'
'
'It is the calling routine's responsibility to DISABLE Excel Events
Dim sOldValueF As String
Dim sValueF As String
'Get the New Value in Column 'F'
'Get the Old Value in Column 'F'
sValueF = Target.Value
sOldValueF = sGblCurrentNameInColumnF
Call CreateDataValidationListForOneName(sValueF)
Call CreateDataValidationListForOneName(sOldValueF)
End Sub
Sub CreateDataValidationListForOneName(sValueF As String)
'This process a Change in One Cell in Column 'F'
'
'It is the calling routine's responsibility to DISABLE Excel Events
'
'NOTE: When a value changes in Column 'F', it also means an old value no longer exists
Dim myRange As Range
Dim r As Range
Dim i As Long
Dim iLastIndex As Long
Dim a() As String
Dim sAddress As String
Dim sDataValidationList As String
Dim sFirstAddress As String
Dim sListOfAddresses As String
Dim sValueG As String
Dim sValueGList As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create a List of All Users in Column 'G' associated with with the Input Name in Column 'F'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the 'Search Range'
Set myRange = ActiveSheet.Range("F3:F" & Rows.Count)
'Find the first occurence of the string
Set r = Nothing
Set r = myRange.Find( _
What:=sValueF, _
After:=ActiveSheet.Range("F3"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not r Is Nothing Then
'Save the found address as the 'First Address'
sFirstAddress = r.Address(False, False) '(False, False) removes '$' signs from the address
'Process the first match, then search for additional values
'If found add them to the array to be returned
While sAddress <> sFirstAddress
'Create a List of Addresses separated by COMMAs that contain the Name in Column 'F'
If Len(sAddress) = 0 Then
sAddress = sFirstAddress 'Special Processing for first match
sListOfAddresses = sFirstAddress
Else
sListOfAddresses = sListOfAddresses & "," & sAddress
End If
'Get the Column 'G' Value (remove leading/trailing spaces
sValueG = Trim(r.Offset(0, 1).Value)
'Add a Leading and Trailing Space to the Column 'G' value
'If the value is BLANK (or all spaces) set the value to a SINGLE SPACE
If Len(Trim(sValueG)) > 0 Then
sValueG = " " & sValueG & " "
Else
sValueG = " "
End If
If sValueGList Like "*" & sValueG & "*" Then
'Do nothing, the Column 'G' Value is already in the dictionary
ElseIf sValueGList = " " Or Len(sValueGList) = 0 Then
'The existing List is a 'SINGLE SPACE' - replace the 'SINGLE SPACE' with the value
sValueGList = sValueG
Else
'The Item is UNIQUE, add a Comma, and the Item to the Column 'G' List
sValueGList = sValueGList & "," & sValueG
End If
'Find the next match
Set r = myRange.FindNext(After:=r)
sAddress = r.Address(False, False)
Wend
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Alphabetize the List and Prepend 'New Name' to the List
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove Leading/Trailing Spaces and combinations of multiple spaces in the list
'Replace all 'COMMA SPACE' combinations with a COMMA
'Replace all 'SPACE COMMA' combinations with a COMMA
sValueGList = Application.WorksheetFunction.Trim(sValueGList)
sValueGList = Replace(sValueGList, ", ", ",") 'Replace all 'COMMA SPACE' combinations with a COMMA
sValueGList = Replace(sValueGList, " ,", ",") 'Replace all 'SPACE COMMA combinations with a COMMA
'Extract all the names into an array
'Sort the Array
iLastIndex = LjmParseString(sValueGList, a)
If iLastIndex >= 0 Then
Call LjmBubbleSortString(a)
End If
'Add the Names to the 'Data Validation List' one at a time
For i = 0 To iLastIndex
sValueG = a(i)
sDataValidationList = sDataValidationList & "," & sValueG
Next i
'Prepend 'New Name' to the list
sDataValidationList = "New Name," & sDataValidationList
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Update 'Data Validation' for this user
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Range of items in the List
'The Range is For Column 'F' and we Need the Range to be for Column 'G'
' so the range has to be moved one column to the right
Set myRange = ActiveSheet.Range(sListOfAddresses)
Set myRange = myRange.Offset(, 1)
'Debug.Print myRange.Address
'Add the Data Validation Value for all cells in Column 'G' that
'have the same Name in Column 'F'
With myRange.Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=sDataValidationList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
'Clear object pointers
Set myRange = Nothing
Set r = Nothing
End Sub
Sub CreateTheEntireDataValidationList()
'This creates a 'Data Validation' list for each cell in Column 'G', based on the cells in Column 'F'
'
'It is the calling routine's responsibility to DISABLE Excel Events
Dim myDictionary As Object
Dim i As Long
Dim iFirstDataRow As Long
Dim iLastDataRow As Long
Dim iLastIndex As Long
Dim iRow As Long
Dim a() As String
Dim sItemValue As String
Dim sDataValidationList As String
Dim sValue As String
Dim sValueF As String
Dim sValueG As String
''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''
'Get the First and Last 'Absolute' Data Rows from Global Values
iFirstDataRow = 4
iLastDataRow = ActiveSheet.Columns("F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Delete Data Validation in the Entire Column 'G'
ActiveSheet.Range("G:G").Validation.Delete
'Create the Scripting Dictionary
'KEY: Name in Column 'F'
'ITEM: Unique Names in Column 'G' Comma Delimited - e.g ' Moe , Larry , Curly Joe ')
' NOTE: Each Name has a leading and trailing SPACE for Search Purposes
Set myDictionary = CreateObject("Scripting.Dictionary")
myDictionary.CompareMode = vbTextCompare 'case insensitive (vbTextCompare = 1)
''''''''''''''''''''''''''''''''''''''''''''''''
'Put Unique Items in the Dictionary
'Add Unique Column 'G' Names as items
''''''''''''''''''''''''''''''''''''''''''''''''
For iRow = iFirstDataRow To iLastDataRow
'Get the Next 'Value' (without leading/trailing spaces) in both column 'F' and column 'G'
sValueF = Trim(ActiveSheet.Cells(iRow, "F").Value)
sValueG = Trim(ActiveSheet.Cells(iRow, "G").Value)
'Add a Leading and Trailing Space to the Column 'G' value
'If the value is BLANK (or all spaces) set the value to a SINGLE SPACE
If Len(Trim(sValueG)) > 0 Then
sValueG = " " & sValueG & " "
Else
sValueG = " "
End If
'If the 'Value' is NOT in the Dictionary, add the Value and the Value in Column 'G' to the Dictionary
'If the 'Value' in Column 'G' is BLANK (or all spaces), add a 'SINGLE SPACE'
'Otherwise, add the value in Column 'G' as an Item, if it is not already in the entry
If myDictionary.exists(sValueF) = False Then
myDictionary.Add sValueF, sValueG
Else
sItemValue = myDictionary.Item(sValueF)
If sItemValue Like "*" & sValueG & "*" Then
'Do nothing, the item is already in the dictionary
ElseIf sItemValue = " " Then
'The existing item is a 'SINGLE SPACE' - replace the 'SINGLE SPACE' with the value
myDictionary.Item(sValueF) = sValueG
Else
'The Item is UNIQUE, add a Comma, and the Item to the Dictionary
myDictionary.Item(sValueF) = sItemValue & "," & sValueG
End If
End If
Next iRow
'Set the CONDITIONAL COMPILATION CONSTANT below to 'True' to output Dictionary Debug Values to the Immediate Window (CTRL G in debugger)
'Set the CONDITIONAL COMPILATION CONSTANT below to 'False' to NOT output Dictionary Debug Values to the Immediate Window (CTRL G in debugger)
#Const NEED_SHEET10_DICTIONARY_DEBUG_OUTPUT = False
#If NEED_SHEET10_DICTIONARY_DEBUG_OUTPUT = True Then
For i = 0 To myDictionary.Count - 1
Debug.Print i, myDictionary.keys()(i), myDictionary.items()(i)
Next i
#End If
''''''''''''''''''''''''''''''''''''''''''''''''
'Create the 'Data Validation' List for each Cell in Column 'G'
'and put 'Data Validation' in that cell
''''''''''''''''''''''''''''''''''''''''''''''''
For iRow = iFirstDataRow To iLastDataRow
'Get the Next 'Value' (without leading/trailing spaces) in both column 'F' and column 'G'
sValueF = Trim(ActiveSheet.Cells(iRow, "F").Value)
'Process only if the value in Column 'F' is NOT BLANK
If Len(sValueF) > 0 Then
'Get the List of 'Unique Names' associated with the name in Column 'F'
'Remove Leading/Trailing Spaces and combinations of multiple spaces in the list
'Replace all 'COMMA SPACE' combinations with a COMMA
'Replace all 'SPACE COMMA' combinations with a COMMA
sDataValidationList = myDictionary.Item(sValueF)
sDataValidationList = Application.WorksheetFunction.Trim(sDataValidationList)
sDataValidationList = Replace(sDataValidationList, ", ", ",") 'Replace all 'COMMA SPACE' combinations with a COMMA
sDataValidationList = Replace(sDataValidationList, " ,", ",") 'Replace all 'SPACE COMMA combinations with a COMMA
'Extract all the names into an array
'Sort the Array
iLastIndex = LjmParseString(sDataValidationList, a)
If iLastIndex >= 0 Then
Call LjmBubbleSortString(a)
End If
'Prepend 'New Name' to the list
sDataValidationList = "New Name"
'Add the Names to the 'Data Validation List' one at a time
For i = 0 To iLastIndex
sValue = a(i)
sDataValidationList = sDataValidationList & "," & sValue
Next i
'Add the Data Validation Value
With ActiveSheet.Cells(iRow, "G").Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=sDataValidationList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
Next iRow
'Clear the Dictionary
myDictionary.RemoveAll
'Clear object pointers
Set myDictionary = Nothing
End Sub
Sub NewNameInColumnGDataEntry(ByVal Target As Range)
'This performs 'Data Entry' for a New Name in Column 'G'
'
'It is the calling routine's responsibility to DISABLE Excel Events
Dim sValueF As String
Dim sValueG As String
'Do not process if more than one cell is changed
'this should never occur because other routines protect against this occurrence
If Target.Count > 1 Then
MsgBox "Unable to Process a 'New Name' because more than one cell changed value."
Exit Sub
End If
'Get the 'New Value' in the Cell in Column 'G'
sValueG = Trim(Target.Value)
'Get the Value in Column 'F'
sValueF = Trim(Target.Offset(0, -1).Value)
'Do NOT process if Column 'F' is BLANK
If Len(sValueF) = 0 Then
Exit Sub
End If
If sValueG = "New Name" Then
sValueG = ""
sValueG = InputBox("Enter the 'New Name' for this Cell. Enter a SPACE CHARACTER to delete the current name. ", _
"New Name Data Entry")
If Len(sValueG) = 0 Then
'Restore the Previous (Original) value in Column 'G'
Target.Value = sGblCurrentNameInColumnG
Else
'Put the value just entered by the User in Column 'G'
sValueG = Trim(sValueG)
Target.Value = sValueG
'Update the 'Data Validation List' for the name in Column 'F'
'NOTE: Target.Offset(0, -1) is the Range Object for one cell to the left (i.e. Column 'F')
Call CreateDataValidationForOneNameController(Target.Offset(0, -1))
End If
End If
End Sub
Sub LjmBubbleSortString(ByRef myArray() As String)
'This sorts a string array in ascending order using a 'Bubble Sort' algorithm
Dim iFirst As Integer
Dim iLast As Integer
Dim i As Integer
Dim j As Integer
Dim sTemp As String
'Get the start and end indices
iFirst = LBound(myArray)
iLast = UBound(myArray)
'Sort
For i = iFirst To iLast - 1
For j = i + 1 To iLast
If myArray(i) > myArray(j) Then
sTemp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = sTemp
End If
Next j
Next i
End Sub
Function LjmParseString(InputString As String, ByRef sArray() As String) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a comma delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
Dim LastNonEmpty As Long
Dim iSplitIndex As Long
'Initialization
LastNonEmpty = -1
'Split the string into tokens
sArray = Split(InputString, ",")
iSplitIndex = UBound(sArray)
'Remove the null tokens
For i = 0 To iSplitIndex
If sArray(i) <> "" Then
'Get rid of all the whitespace
LastNonEmpty = LastNonEmpty + 1
sArray(LastNonEmpty) = sArray(i)
End If
Next i
'Return the number of indices
LjmParseString = LastNonEmpty
End Function
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks