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-
In "This Workbook" I have used the code -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
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.
Message Prompting.jpg
Reply With Quote
