Re: Event Macro to add logic to the cells in the worksheet
I just uploaded a workbook based on the one you posted earlier. I have added code to it to do what you want in as generalized a way as I could.
There is code in the ThisWorkbook module and in three regular modules.
In ThisWorkbook:
Option Explicit
Private Sub Workbook_Open()
Dim ws As Worksheet, rng As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rngBlueColumns = Nothing
For Each rng In ws.Range("1:1")
If Not IsEmpty(rng) Then
If rng.Interior.ColorIndex = 37 Then
If rngBlueColumns Is Nothing Then
Set rngBlueColumns = rng
Else
Set rngBlueColumns = Application.Union(rngBlueColumns, rng)
End If
End If
End If
Next rng
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng As Range
If Sh.Name <> "Sheet1" Then Exit Sub
Set rng = Sh.Cells(1, Target.Column)
Application.EnableEvents = False
If Not Application.Intersect(rng, rngBlueColumns) Is Nothing Then
Call ChangeAll(Target)
Else
Application.Undo
End If
Application.EnableEvents = True
End Sub
Display More
We capture two events, the Workbook_Open and the Workbook_SheetChange events. Workbook_Open simply initializes the global variable rngBlueColumns before any processing takes place so when a user tries to change a non-blue column it will act as though it were locked.
Workbook_SheetChange captures any user changes to a cell. if the cell is NOT in a blue column, the change is Undone and goes back to the user. It the cell is in a blue column, the routine ChangeAll is called passing the range of the changed cell.
Note that Application.EnableEvents is turned off prior to making any cell changes and then back on before returning to the user.
In MGlobals module:
Option Explicit
Public rngBlueColumns As Range
We merely define the global (Public) Range variable so we can initialize it in the Workbook_Open code and use it in the Workbook_SheetChange code.
In MFindRange module:
Option Explicit
Enum eLookin
xl_Formulas = -4123
xl_Comments = -4144
xl_Values = -4163
End Enum
Enum eLookat
xl_Part = 2
xl_Whole = 1
End Enum
Function FindRange(Find_Item As Variant, Search_Range As Range, _
Optional LookIn As eLookin, Optional LookAt As eLookat, _
Optional MatchCase As Boolean) As Range
Dim c As Range, FirstAddress As String '<<
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False
With Search_Range
Set c = .Find(What:=Find_Item, LookIn:=LookIn, LookAt:=LookAt, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set FindRange = c
FirstAddress = c.Address
Do
Set FindRange = Union(FindRange, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End Function
Display More
This code is from http://www.ozgrid.com/forum/showthread.php?t=27240
It may be old but it still runs like a champ!
Finally, in Module1 module:
Option Explicit
Sub ChangeAll(inTarget As Range)
Dim strSearchValue As String, strChangeValue As String
Dim rngFound As Range, rngTemp As Range, lTargetCol As Long
lTargetCol = inTarget.Column
strSearchValue = Worksheets("Sheet1").Cells(inTarget.Row, 2).Value
strChangeValue = inTarget.Value
Set rngFound = FindRange(strSearchValue, Columns("B"), xl_Values, xl_Whole)
[COLOR=#ff0000] If Not rngFound Is Nothing Then
For Each rngTemp In rngFound
Cells(rngTemp.Row, lTargetCol).Value = strChangeValue
Next rngTemp
End If
[/COLOR]End Sub
Display More
Here we just save some information in local variables, call the FindRange routine to search for all the entries with the same value as the Target row. If we find any (should always find at least 1) we loop through the cells found and change the corresponding column to the new value.
I just realized, you wanted to prompt the user with a MsgBox if they wanted to make the change to each found cell. Here is the code change to do that:
If Not rngFound Is Nothing Then
For Each rngTemp In rngFound
If rngTemp.Row <> inTarget.Row Then
If MsgBox("Make this change to row " & rngTemp.Row, vbYesNo) = vbYes Then
Cells(rngTemp.Row, lTargetCol).Value = strChangeValue
End If
End If
Next rngTemp
End If
Replace the red code in the previous segment with this code to use the MsgBox prompt to approve the changes.
I hope this works for you. If you have any questions please ask. My coding isn't complete until you understand how it works and why.
Remember -- The unasked question never gets answered!
