paradise
02-15-2017, 08:14 PM
Hi,
I am facing a problem which is enclosed in snapshot below.Every now & then when I add data & save it.And Open it ,it starts repairing & rebuilding workbook & thus result in structural change in workbook.I have used the vba code in Sheet Module-
Option Explicit
'List of Sheets to be INCLUDED, each Sheet Name MUST be separated by commas (e.g. sGblSheetsToIncludeLIST = "Sheet3, Sheet4" )
'The list is CASE INSENSITIVE
Public Const sGblSheetsToIncludeLIST = "Printing, Lamination"
'Global Variables
Public sGblCurrentNameInColumnF As String
Public sGblCurrentNameInColumnG As String
Public iGblNumberOfWorksheetsToUse As Long
Public sGblSheetsToIncludeArray() As String
Sub EnableExcelEvents()
Application.EnableEvents = False
MsgBox "Excel Events are enabled."
End Sub
Sub DisableExcelEvents()
Application.EnableEvents = True
MsgBox "Excel Events are disabled."
End Sub
Sub CreateDataValidationListInColumnGOnAllSheets()
'This creates a 'Data Validation' list for each cell in Column 'G' (on all Sheets), based on the cells in Column 'F'
'
'It is the calling routine's responsibility to DISABLE Excel Events
Dim myDictionaryF As Object
Dim wks As Worksheet
Dim i As Long
Dim iFirstDataRow As Long
Dim iLastDataRow As Long
Dim iRow As Long
Dim iSheetNumber As Long
Dim sSheetNameX As String
Dim sValueF As String
''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''
'Create a Global Array of Worksheets to Use (if the array does not already exist)
'and the Global Count of Worksheets to Use
'Exit if there are NO Worksheets to Use
Call CreateGlobalSheetsToIncludeArrayIfNeeded(sGblSheetsToIncludeLIST)
If iGblNumberOfWorksheetsToUse = 0 Then
Exit Sub
End If
'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' on All Worksheets
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
wks.Range("G:G").Validation.Delete
Next iSheetNumber
'Create the Scripting Dictionary for Column 'F'
'KEY: Name in Column 'F'
'ITEM: Unique Names in Column 'G' Comma Delimited - e.g ' Moe , Larry , Curly Joe ')
' The First Item is always 'New Name'
Set myDictionaryF = CreateObject("Scripting.Dictionary")
myDictionaryF.CompareMode = vbTextCompare 'case insensitive (vbTextCompare = 1)
''''''''''''''''''''''''''''''''''''''''''''''''
'Put Unique Items in the Dictionary
'Add Unique Column 'G' Names as items
''''''''''''''''''''''''''''''''''''''''''''''''
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
'Get the next 'Sheet Name' to Process
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
'Get the First and Last 'Absolute' Data Rows
iFirstDataRow = 4
iLastDataRow = 0
On Error Resume Next
iLastDataRow = wks.Columns("F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
For iRow = iFirstDataRow To iLastDataRow
'Get the Next 'Value' (without leading/trailing spaces) in column ''F'
sValueF = Trim(ActiveSheet.Cells(iRow, "F").Value)
'Ignore Blank Rows in Column 'F'
'Process the Row only if it is the 'First Time' the Value has been
'found in Column 'F' on any Sheet
If Len(sValueF) = 0 Then
'Do Nothing for a Blank Row on Column 'F'
ElseIf myDictionaryF.exists(sValueF) = False Then
'Add the Column 'F' value to the Dictionary
myDictionaryF.Add sValueF, sSheetNameX & " Row" & Format(iRow, "0000")
'Find All Matches on All Sheets for the Column 'F' Value
'Put 'Data Validation' for the Column 'F' Value on all Sheets
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
Next iRow
Next iSheetNumber
#Const NEED_DICTIONARYF_DEBUG_OUTPUT = False
#If NEED_DICTIONARYF_DEBUG_OUTPUT = True Then
For i = 0 To myDictionaryF.Count - 1
Debug.Print i, myDictionaryF.keys()(i), myDictionaryF.items()(i)
Next i
#End If
'Clear the Dictionary
myDictionaryF.RemoveAll
'Clear object pointers
Set myDictionaryF = Nothing
Set wks = Nothing
End Sub
Sub CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF As String)
'This adds 'Data Validation' for one Column 'F' value on All Sheets
Dim wks As Worksheet
Dim i As Long
Dim iLastIndex As Long
Dim iSheetNumber As Long
Dim a() As String
Dim sAddressList As String
Dim sAddressListArray() As String
Dim sDataValidationList As String
Dim sSheetNameX As String
Dim sValue As String
Dim sValueGList As String
'Find All Matches on All Sheets for the Column 'F' Value
'Put 'Data Validation' for the Column 'F' Value on all Sheets
'Initialize the 'Address List' Array
ReDim sAddressListArray(1 To iGblNumberOfWorksheetsToUse)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Find all occurrences of the value in Column 'F' on each Sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
sAddressList = GetListOfAddressMatchesOnSheetXForColumnF(wks, sValueF, sValueGList)
If Len(sAddressList) = 0 Then
'Debug.Print sValueF, sSheetNameX, "NO MATCHES"
Else
'Debug.Print sValueF, sSheetNameX, sAddressList
End If
'Add the List to the Array of Addresses
sAddressListArray(iSheetNumber) = sAddressList
Next iSheetNumber
'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 = sValueGList
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 (after removing leading/trailing Brackets)
'Do NOT allow 'New Name' to be added a 2nd time to the List
For i = 0 To iLastIndex
sValue = a(i)
sValue = Mid(sValue, 2, Len(sValue) - 2)
If UCase(sValue) <> "NEW NAME" Then
sDataValidationList = sDataValidationList & "," & sValue
End If
Next i
'Put 'Data Validation' in each Sheet
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
'Get 'Address List' for this Sheet
sAddressList = Trim(sAddressListArray(iSheetNumber))
If Len(sAddressList) > 0 Then
'Add Data Validation to this Sheet if the 'Address List' for this Sheet is NOT BLANK
'Move the Range one cell to the right
With wks.Range(sAddressList).Offset(0, 1).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 iSheetNumber
End Sub
Function GetListOfAddressMatchesOnSheetXForColumnF(ws As Worksheet, sValueF As String, ByRef sValueGList As String) As String
'This returns the Range of Matches for a Column 'F' value that are
'in Column 'F' on the specified Sheet
'
' 'ByRef' items are modified by this routine
Dim myRange As Range
Dim r As Range
Dim sAddress As String
Dim sFirstAddress As String
Dim sListOfAddresses As String
Dim sValueG As String
'Create the 'Search Range'
Set myRange = ws.Range("F3:F" & Rows.Count)
'Find the first occurence of the string
Set r = Nothing
Set r = myRange.Find( _
What:=sValueF, _
After:=ws.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)
'Enclose the Column 'G' value in Brackets '< >'
If Len(Trim(sValueG)) > 0 Then
sValueG = "<" & sValueG & ">"
Else
sValueG = ""
End If
If Len(sValueG) = 0 Then
'Do nothing - the Column 'G' Value is BLANK
ElseIf sValueGList Like "*" & sValueG & "*" Then
'Do nothing, the Column 'G' Value is already in the list
ElseIf Len(sValueGList) = 0 Then
'The existing List is BLANK, put the value in the List (as the only 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
End If
'Debug.Print "sValueGList", sValueGList
'Set the Return Value
GetListOfAddressMatchesOnSheetXForColumnF = sListOfAddresses
End Function
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'
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
Else
'The name in Column 'G' changed
'Update the 'Data Validation List' for the name in Column 'F'
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
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
Function LjmSheetExists(SheetName As String) As Boolean
'Return value TRUE if sheet exists
On Error Resume Next
If Sheets(SheetName) Is Nothing Then
LjmSheetExists = False
Else
LjmSheetExists = True
End If
On Error GoTo 0
End Function
Sub CreateGlobalSheetsToIncludeArrayIfNeeded(sIncludeList As String)
'This creates a Global array of Sheets to be 'Included' (and that also Exist) by parsing
'a 'comma separated' list of Sheets to 'Include'
'
'The Global values created are:
'a. sGblSheetsToIncludeArray()
'b. iGblNumberOfWorksheetsToUse
Dim i As Long
Dim iLastIndex As Long
Dim a() As String
Dim sSheetNameX As String
'Exit if the Array already exists
If iGblNumberOfWorksheetsToUse > 0 Then
Exit Sub
End If
'Parse the Input string
iLastIndex = LjmParseString(sIncludeList, a)
'Create the Global Array
If iLastIndex < 0 Then
ReDim sGblSheetsToIncludeArray(1 To 1)
iGblNumberOfWorksheetsToUse = 0
Else
ReDim sGblSheetsToIncludeArray(1 To 1)
'Put Data in the Global Array (remove leading/trailing spaces)
For i = 0 To iLastIndex
sSheetNameX = Trim(a(i))
If LjmSheetExists(sSheetNameX) = True Then
'Increment the Sheet Counter
'Add space to the Global Array
'Put the 'Sheet Name in the Array
iGblNumberOfWorksheetsToUse = iGblNumberOfWorksheetsToUse + 1
ReDim Preserve sGblSheetsToIncludeArray(1 To iGblNumberOfWorksheetsToUse)
sGblSheetsToIncludeArray(iGblNumberOfWorksheetsToUse) = sSheetNameX
End If
Next i
End If
End Sub
In "This Workbook" I have used the code -
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim myRangeColumnF As Range
Dim r As Range
Dim iRow1 As Long
Dim iRow2 As Long
Dim iColumn1 As Long
Dim iColumn2 As Long
Dim bNeedToUpdateTheEntireList As Boolean
Dim bValuesAlreadyUpdatedForColumnF As Boolean
Dim sOldValueF As String
Dim sValueF As String
Dim sValueG As String
'Disable Excel Events and Screen Updating
Application.EnableEvents = False
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Set the Flag that indicates that only one Column 'F' value needs updating
'if EXACTLY 2 cells were changed on the same row in Column 'F' and Column 'G'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("F4:G" & Rows.Count)) Is Nothing Then
If Target.Count = 2 Then
iRow1 = Target(1).Row
iRow2 = Target(2).Row
iColumn1 = Target(1).Column
iColumn2 = Target(2).Column
If iRow1 = iRow2 And iColumn1 + 1 = iColumn2 Then
Debug.Print "Update Target.Count = 2 performed at " & Now()
'Get the 'New' and 'Old' Values in Column 'F'
sValueF = Trim(Sh.Cells(iRow1, iColumn1).Value)
sOldValueF = sGblCurrentNameInColumnF
'Update 'Data Validation' in Column 'G' for all cells for the 'New Value' in
'Column 'F', unless the Column 'F' 'New Value' is BLANK
If Len(sValueF) = 0 Then
'Remove 'Data Validation' from Column 'G'
Target.Offset(0, 1).Validation.Delete
Else
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
'Update 'Data Validation' in Column 'G' for all cells for the 'Old Value' in
'Column 'F', unless the Column 'F' 'Old Value' is BLANK
If Len(sOldValueF) > 0 Then
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sOldValueF)
End If
'Set the Flag that indicates Column 'F' update was already done
bValuesAlreadyUpdatedForColumnF = True
End If
'Debug.Print Target(1).Address
'Debug.Print Target(2).Address
'Debug.Print Target(1).Column, Target(1).Row
'Debug.Print Target(2).Column, Target(2).Row
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Update the 'Data Validation Lists if a change is made in Column 'F'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("F4:F" & Rows.Count)) Is Nothing Then
'Clear Values in Column 'G' if the Column 'F' value is BLANK
Set myRangeColumnF = Intersect(Target, Range("F4:F" & Rows.Count))
For Each r In myRangeColumnF
Debug.Print r.Address, r.Offset(0, 1).Address, r.Offset(0, 1).Value
sValueF = Trim(r.Value)
If Len(sValueF) = 0 Then
r.Offset(0, 1).Value = ""
End If
Next r
'Process Changes in Column 'F'
If bValuesAlreadyUpdatedForColumnF = True Then
'Do nothing - Update already done above
ElseIf Target.Count > 1 Then
'We need to update the Entire 'Data Validation List' because more than one name was changed
'Set a flag instead of calling the routine, so the routine is only executed once
bNeedToUpdateTheEntireList = True
Else
'Update 'Data Validation' for only the Name that changed
'Get the 'New' and 'Old' Values in Column 'F'
sValueF = Trim(Target.Value)
sOldValueF = sGblCurrentNameInColumnF
'If the Column 'F' 'New Value' is BLANK, remove 'Data Validation' in Column 'G'
'and keep the original value in Column 'G'
'Otherwise, Update 'Data Validation' in Column 'G' for all cells for the 'New Value' in Column 'F'
If Len(sValueF) = 0 Then
Target.Offset(0, 1).Validation.Delete
Else
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
'Update 'Data Validation' in Column 'G' for all cells for the 'Old Value' in
'Column 'F', unless the Column 'F' 'Old Value' is BLANK
If Len(sOldValueF) > 0 Then
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sOldValueF)
End If
Debug.Print "Update Target.Count = 1 Column 'F' performed at " & Now()
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Allow User to Enter a 'New Name' if there is a Change in Column 'G'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("G4:G" & Rows.Count)) Is Nothing Then
If bValuesAlreadyUpdatedForColumnF = True Then
'Do nothing - Update already done above
ElseIf Target.Count > 1 Then
'We need to update the Entire 'Data Validation List' because more than one name was changed
'Set a flag instead of calling the routine, so the routine is only executed once
bNeedToUpdateTheEntireList = True
Else
Call NewNameInColumnGDataEntry(Target)
Debug.Print "Update Target.Count = 1 Column 'G' performed at " & Now()
End If
End If
'Update the Entire 'Data Validation List' because more than one name was changed
If bNeedToUpdateTheEntireList = True Then
Call CreateDataValidationListInColumnGOnAllSheets
Debug.Print "Update Entire List performed at " & Now()
End If
MYEXIT:
'Enable Excel Events and Screen Updating
Application.EnableEvents = True
Application.ScreenUpdating = True
'Clear object pointers
Set myRangeColumnF = Nothing
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim myRangeColumnF As Range
Dim myRangeColumnG As Range
'Save the Current Value (in Column 'F' only) - only if 1 Cell was selected
'Otherwise, set the Current Value to BLANK
If Not Intersect(Target, Range("F4:F" & Rows.Count)) Is Nothing Then
'Get the Column 'F' Values Only
'Use 'Resize' in case more than one cell was selected
Set myRangeColumnF = Intersect(Target, Range("F4:F" & Rows.Count))
If myRangeColumnF.Count = 1 Then
sGblCurrentNameInColumnF = myRangeColumnF(1).Value
Else
sGblCurrentNameInColumnF = ""
End If
End If
'Save the Current Value (in Column 'G' only) - only if 1 Cell was selected
'Otherwise, set the Current Value to BLANK
If Not Intersect(Target, Range("G4:G" & Rows.Count)) Is Nothing Then
'Get the Column 'G' Values Only
'Use 'Resize' in case more than one cell was selected
Set myRangeColumnG = Intersect(Target, Range("G4:G" & Rows.Count))
If myRangeColumnG.Count = 1 Then
sGblCurrentNameInColumnG = myRangeColumnG(1).Value
Else
sGblCurrentNameInColumnG = ""
End If
End If
'Clear object pointers
Set myRangeColumnF = Nothing
Set myRangeColumnG = Nothing
End Sub
In subsequent rows in F column I do copy paste work,using formula and even typing work also.So that I can get data validation in G column subsequent rows.Remaining columns are there where manual data is there and some formula.My main purpose is of F column & G column.That updates the data in user defined sheets.
I want to stop this repairing & rebuilding workbook every now then when opening workbook.Hope someone will help me resolving this issue.
If anyone require further informations,then kindly let me know.
18387
I am facing a problem which is enclosed in snapshot below.Every now & then when I add data & save it.And Open it ,it starts repairing & rebuilding workbook & thus result in structural change in workbook.I have used the vba code in Sheet Module-
Option Explicit
'List of Sheets to be INCLUDED, each Sheet Name MUST be separated by commas (e.g. sGblSheetsToIncludeLIST = "Sheet3, Sheet4" )
'The list is CASE INSENSITIVE
Public Const sGblSheetsToIncludeLIST = "Printing, Lamination"
'Global Variables
Public sGblCurrentNameInColumnF As String
Public sGblCurrentNameInColumnG As String
Public iGblNumberOfWorksheetsToUse As Long
Public sGblSheetsToIncludeArray() As String
Sub EnableExcelEvents()
Application.EnableEvents = False
MsgBox "Excel Events are enabled."
End Sub
Sub DisableExcelEvents()
Application.EnableEvents = True
MsgBox "Excel Events are disabled."
End Sub
Sub CreateDataValidationListInColumnGOnAllSheets()
'This creates a 'Data Validation' list for each cell in Column 'G' (on all Sheets), based on the cells in Column 'F'
'
'It is the calling routine's responsibility to DISABLE Excel Events
Dim myDictionaryF As Object
Dim wks As Worksheet
Dim i As Long
Dim iFirstDataRow As Long
Dim iLastDataRow As Long
Dim iRow As Long
Dim iSheetNumber As Long
Dim sSheetNameX As String
Dim sValueF As String
''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
''''''''''''''''''''''''''''''''''''''''''''''''
'Create a Global Array of Worksheets to Use (if the array does not already exist)
'and the Global Count of Worksheets to Use
'Exit if there are NO Worksheets to Use
Call CreateGlobalSheetsToIncludeArrayIfNeeded(sGblSheetsToIncludeLIST)
If iGblNumberOfWorksheetsToUse = 0 Then
Exit Sub
End If
'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' on All Worksheets
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
wks.Range("G:G").Validation.Delete
Next iSheetNumber
'Create the Scripting Dictionary for Column 'F'
'KEY: Name in Column 'F'
'ITEM: Unique Names in Column 'G' Comma Delimited - e.g ' Moe , Larry , Curly Joe ')
' The First Item is always 'New Name'
Set myDictionaryF = CreateObject("Scripting.Dictionary")
myDictionaryF.CompareMode = vbTextCompare 'case insensitive (vbTextCompare = 1)
''''''''''''''''''''''''''''''''''''''''''''''''
'Put Unique Items in the Dictionary
'Add Unique Column 'G' Names as items
''''''''''''''''''''''''''''''''''''''''''''''''
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
'Get the next 'Sheet Name' to Process
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
'Get the First and Last 'Absolute' Data Rows
iFirstDataRow = 4
iLastDataRow = 0
On Error Resume Next
iLastDataRow = wks.Columns("F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
For iRow = iFirstDataRow To iLastDataRow
'Get the Next 'Value' (without leading/trailing spaces) in column ''F'
sValueF = Trim(ActiveSheet.Cells(iRow, "F").Value)
'Ignore Blank Rows in Column 'F'
'Process the Row only if it is the 'First Time' the Value has been
'found in Column 'F' on any Sheet
If Len(sValueF) = 0 Then
'Do Nothing for a Blank Row on Column 'F'
ElseIf myDictionaryF.exists(sValueF) = False Then
'Add the Column 'F' value to the Dictionary
myDictionaryF.Add sValueF, sSheetNameX & " Row" & Format(iRow, "0000")
'Find All Matches on All Sheets for the Column 'F' Value
'Put 'Data Validation' for the Column 'F' Value on all Sheets
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
Next iRow
Next iSheetNumber
#Const NEED_DICTIONARYF_DEBUG_OUTPUT = False
#If NEED_DICTIONARYF_DEBUG_OUTPUT = True Then
For i = 0 To myDictionaryF.Count - 1
Debug.Print i, myDictionaryF.keys()(i), myDictionaryF.items()(i)
Next i
#End If
'Clear the Dictionary
myDictionaryF.RemoveAll
'Clear object pointers
Set myDictionaryF = Nothing
Set wks = Nothing
End Sub
Sub CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF As String)
'This adds 'Data Validation' for one Column 'F' value on All Sheets
Dim wks As Worksheet
Dim i As Long
Dim iLastIndex As Long
Dim iSheetNumber As Long
Dim a() As String
Dim sAddressList As String
Dim sAddressListArray() As String
Dim sDataValidationList As String
Dim sSheetNameX As String
Dim sValue As String
Dim sValueGList As String
'Find All Matches on All Sheets for the Column 'F' Value
'Put 'Data Validation' for the Column 'F' Value on all Sheets
'Initialize the 'Address List' Array
ReDim sAddressListArray(1 To iGblNumberOfWorksheetsToUse)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Find all occurrences of the value in Column 'F' on each Sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
sAddressList = GetListOfAddressMatchesOnSheetXForColumnF(wks, sValueF, sValueGList)
If Len(sAddressList) = 0 Then
'Debug.Print sValueF, sSheetNameX, "NO MATCHES"
Else
'Debug.Print sValueF, sSheetNameX, sAddressList
End If
'Add the List to the Array of Addresses
sAddressListArray(iSheetNumber) = sAddressList
Next iSheetNumber
'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 = sValueGList
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 (after removing leading/trailing Brackets)
'Do NOT allow 'New Name' to be added a 2nd time to the List
For i = 0 To iLastIndex
sValue = a(i)
sValue = Mid(sValue, 2, Len(sValue) - 2)
If UCase(sValue) <> "NEW NAME" Then
sDataValidationList = sDataValidationList & "," & sValue
End If
Next i
'Put 'Data Validation' in each Sheet
For iSheetNumber = 1 To iGblNumberOfWorksheetsToUse
sSheetNameX = sGblSheetsToIncludeArray(iSheetNumber)
Set wks = ThisWorkbook.Sheets(sSheetNameX)
'Get 'Address List' for this Sheet
sAddressList = Trim(sAddressListArray(iSheetNumber))
If Len(sAddressList) > 0 Then
'Add Data Validation to this Sheet if the 'Address List' for this Sheet is NOT BLANK
'Move the Range one cell to the right
With wks.Range(sAddressList).Offset(0, 1).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 iSheetNumber
End Sub
Function GetListOfAddressMatchesOnSheetXForColumnF(ws As Worksheet, sValueF As String, ByRef sValueGList As String) As String
'This returns the Range of Matches for a Column 'F' value that are
'in Column 'F' on the specified Sheet
'
' 'ByRef' items are modified by this routine
Dim myRange As Range
Dim r As Range
Dim sAddress As String
Dim sFirstAddress As String
Dim sListOfAddresses As String
Dim sValueG As String
'Create the 'Search Range'
Set myRange = ws.Range("F3:F" & Rows.Count)
'Find the first occurence of the string
Set r = Nothing
Set r = myRange.Find( _
What:=sValueF, _
After:=ws.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)
'Enclose the Column 'G' value in Brackets '< >'
If Len(Trim(sValueG)) > 0 Then
sValueG = "<" & sValueG & ">"
Else
sValueG = ""
End If
If Len(sValueG) = 0 Then
'Do nothing - the Column 'G' Value is BLANK
ElseIf sValueGList Like "*" & sValueG & "*" Then
'Do nothing, the Column 'G' Value is already in the list
ElseIf Len(sValueGList) = 0 Then
'The existing List is BLANK, put the value in the List (as the only 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
End If
'Debug.Print "sValueGList", sValueGList
'Set the Return Value
GetListOfAddressMatchesOnSheetXForColumnF = sListOfAddresses
End Function
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'
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
Else
'The name in Column 'G' changed
'Update the 'Data Validation List' for the name in Column 'F'
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
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
Function LjmSheetExists(SheetName As String) As Boolean
'Return value TRUE if sheet exists
On Error Resume Next
If Sheets(SheetName) Is Nothing Then
LjmSheetExists = False
Else
LjmSheetExists = True
End If
On Error GoTo 0
End Function
Sub CreateGlobalSheetsToIncludeArrayIfNeeded(sIncludeList As String)
'This creates a Global array of Sheets to be 'Included' (and that also Exist) by parsing
'a 'comma separated' list of Sheets to 'Include'
'
'The Global values created are:
'a. sGblSheetsToIncludeArray()
'b. iGblNumberOfWorksheetsToUse
Dim i As Long
Dim iLastIndex As Long
Dim a() As String
Dim sSheetNameX As String
'Exit if the Array already exists
If iGblNumberOfWorksheetsToUse > 0 Then
Exit Sub
End If
'Parse the Input string
iLastIndex = LjmParseString(sIncludeList, a)
'Create the Global Array
If iLastIndex < 0 Then
ReDim sGblSheetsToIncludeArray(1 To 1)
iGblNumberOfWorksheetsToUse = 0
Else
ReDim sGblSheetsToIncludeArray(1 To 1)
'Put Data in the Global Array (remove leading/trailing spaces)
For i = 0 To iLastIndex
sSheetNameX = Trim(a(i))
If LjmSheetExists(sSheetNameX) = True Then
'Increment the Sheet Counter
'Add space to the Global Array
'Put the 'Sheet Name in the Array
iGblNumberOfWorksheetsToUse = iGblNumberOfWorksheetsToUse + 1
ReDim Preserve sGblSheetsToIncludeArray(1 To iGblNumberOfWorksheetsToUse)
sGblSheetsToIncludeArray(iGblNumberOfWorksheetsToUse) = sSheetNameX
End If
Next i
End If
End Sub
In "This Workbook" I have used the code -
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim myRangeColumnF As Range
Dim r As Range
Dim iRow1 As Long
Dim iRow2 As Long
Dim iColumn1 As Long
Dim iColumn2 As Long
Dim bNeedToUpdateTheEntireList As Boolean
Dim bValuesAlreadyUpdatedForColumnF As Boolean
Dim sOldValueF As String
Dim sValueF As String
Dim sValueG As String
'Disable Excel Events and Screen Updating
Application.EnableEvents = False
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Set the Flag that indicates that only one Column 'F' value needs updating
'if EXACTLY 2 cells were changed on the same row in Column 'F' and Column 'G'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("F4:G" & Rows.Count)) Is Nothing Then
If Target.Count = 2 Then
iRow1 = Target(1).Row
iRow2 = Target(2).Row
iColumn1 = Target(1).Column
iColumn2 = Target(2).Column
If iRow1 = iRow2 And iColumn1 + 1 = iColumn2 Then
Debug.Print "Update Target.Count = 2 performed at " & Now()
'Get the 'New' and 'Old' Values in Column 'F'
sValueF = Trim(Sh.Cells(iRow1, iColumn1).Value)
sOldValueF = sGblCurrentNameInColumnF
'Update 'Data Validation' in Column 'G' for all cells for the 'New Value' in
'Column 'F', unless the Column 'F' 'New Value' is BLANK
If Len(sValueF) = 0 Then
'Remove 'Data Validation' from Column 'G'
Target.Offset(0, 1).Validation.Delete
Else
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
'Update 'Data Validation' in Column 'G' for all cells for the 'Old Value' in
'Column 'F', unless the Column 'F' 'Old Value' is BLANK
If Len(sOldValueF) > 0 Then
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sOldValueF)
End If
'Set the Flag that indicates Column 'F' update was already done
bValuesAlreadyUpdatedForColumnF = True
End If
'Debug.Print Target(1).Address
'Debug.Print Target(2).Address
'Debug.Print Target(1).Column, Target(1).Row
'Debug.Print Target(2).Column, Target(2).Row
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Update the 'Data Validation Lists if a change is made in Column 'F'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("F4:F" & Rows.Count)) Is Nothing Then
'Clear Values in Column 'G' if the Column 'F' value is BLANK
Set myRangeColumnF = Intersect(Target, Range("F4:F" & Rows.Count))
For Each r In myRangeColumnF
Debug.Print r.Address, r.Offset(0, 1).Address, r.Offset(0, 1).Value
sValueF = Trim(r.Value)
If Len(sValueF) = 0 Then
r.Offset(0, 1).Value = ""
End If
Next r
'Process Changes in Column 'F'
If bValuesAlreadyUpdatedForColumnF = True Then
'Do nothing - Update already done above
ElseIf Target.Count > 1 Then
'We need to update the Entire 'Data Validation List' because more than one name was changed
'Set a flag instead of calling the routine, so the routine is only executed once
bNeedToUpdateTheEntireList = True
Else
'Update 'Data Validation' for only the Name that changed
'Get the 'New' and 'Old' Values in Column 'F'
sValueF = Trim(Target.Value)
sOldValueF = sGblCurrentNameInColumnF
'If the Column 'F' 'New Value' is BLANK, remove 'Data Validation' in Column 'G'
'and keep the original value in Column 'G'
'Otherwise, Update 'Data Validation' in Column 'G' for all cells for the 'New Value' in Column 'F'
If Len(sValueF) = 0 Then
Target.Offset(0, 1).Validation.Delete
Else
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sValueF)
End If
'Update 'Data Validation' in Column 'G' for all cells for the 'Old Value' in
'Column 'F', unless the Column 'F' 'Old Value' is BLANK
If Len(sOldValueF) > 0 Then
Call CreateDataValidationListForOneColumnFValueOnAllSheets(sOldValueF)
End If
Debug.Print "Update Target.Count = 1 Column 'F' performed at " & Now()
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
'Allow User to Enter a 'New Name' if there is a Change in Column 'G'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''
If Not Intersect(Target, Range("G4:G" & Rows.Count)) Is Nothing Then
If bValuesAlreadyUpdatedForColumnF = True Then
'Do nothing - Update already done above
ElseIf Target.Count > 1 Then
'We need to update the Entire 'Data Validation List' because more than one name was changed
'Set a flag instead of calling the routine, so the routine is only executed once
bNeedToUpdateTheEntireList = True
Else
Call NewNameInColumnGDataEntry(Target)
Debug.Print "Update Target.Count = 1 Column 'G' performed at " & Now()
End If
End If
'Update the Entire 'Data Validation List' because more than one name was changed
If bNeedToUpdateTheEntireList = True Then
Call CreateDataValidationListInColumnGOnAllSheets
Debug.Print "Update Entire List performed at " & Now()
End If
MYEXIT:
'Enable Excel Events and Screen Updating
Application.EnableEvents = True
Application.ScreenUpdating = True
'Clear object pointers
Set myRangeColumnF = Nothing
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim myRangeColumnF As Range
Dim myRangeColumnG As Range
'Save the Current Value (in Column 'F' only) - only if 1 Cell was selected
'Otherwise, set the Current Value to BLANK
If Not Intersect(Target, Range("F4:F" & Rows.Count)) Is Nothing Then
'Get the Column 'F' Values Only
'Use 'Resize' in case more than one cell was selected
Set myRangeColumnF = Intersect(Target, Range("F4:F" & Rows.Count))
If myRangeColumnF.Count = 1 Then
sGblCurrentNameInColumnF = myRangeColumnF(1).Value
Else
sGblCurrentNameInColumnF = ""
End If
End If
'Save the Current Value (in Column 'G' only) - only if 1 Cell was selected
'Otherwise, set the Current Value to BLANK
If Not Intersect(Target, Range("G4:G" & Rows.Count)) Is Nothing Then
'Get the Column 'G' Values Only
'Use 'Resize' in case more than one cell was selected
Set myRangeColumnG = Intersect(Target, Range("G4:G" & Rows.Count))
If myRangeColumnG.Count = 1 Then
sGblCurrentNameInColumnG = myRangeColumnG(1).Value
Else
sGblCurrentNameInColumnG = ""
End If
End If
'Clear object pointers
Set myRangeColumnF = Nothing
Set myRangeColumnG = Nothing
End Sub
In subsequent rows in F column I do copy paste work,using formula and even typing work also.So that I can get data validation in G column subsequent rows.Remaining columns are there where manual data is there and some formula.My main purpose is of F column & G column.That updates the data in user defined sheets.
I want to stop this repairing & rebuilding workbook every now then when opening workbook.Hope someone will help me resolving this issue.
If anyone require further informations,then kindly let me know.
18387