Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
If Not Intersect(Target, Range("B2:D2")) Is Nothing Then
Set r = Range("D6:F6")
If Target <> " " Then
With r
.Interior.ColorIndex = 3
End With
End If
End If
End Sub
Option Explicit
Private Const sInputRange As String = "B2:D2"
Private Const sOutputRange As String = "D6:F6"
Private Const iColorIndex As Long = 3
Private Sub Worksheet_Change(ByVal Target As Range)
'Dimension variables
Dim rCell As Range
'Checks for single cell entry only
If Target.Cells.Count > 1 Then Exit Sub
'Checks to see if the target cell is in the specified input range
If Intersect(Target, Me.Range(sInputRange)) Is Nothing Then Exit Sub
'Checks if anything is in the input range
Select Case WorksheetFunction.CountA(Me.Range(sInputRange))
Case Is = 0
'If not, clear out coloring
Me.Range(sOutputRange).Interior.ColorIndex = 0
Case Is = 1
'If so, change the color of the output cells
Me.Range(sOutputRange).Interior.ColorIndex = iColorIndex
Case Else
'More than one value is trying to be entered, clear the entry
'and give a message
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
MsgBox "You can only enter information for one range in " & sInputRange & "!", vbExclamation, "ERROR!"
End Select
End Sub
Dim prevD6Value, prevE6Value, prevF6Value
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = Range("B2:D2")
Set Rng2 = Range("D6:F6")
Application.EnableEvents = False
If Not Intersect(Target, Rng1) Is Nothing Then
'~~~> Code here to fill Rng2
End If
If Not Intersect(Target, Rng2) Is Nothing Then
If WorksheetFunction.CountA(Rng1) > 0 Then
MsgBox "Please note that nothing can be entered in this range"
Range("D6").Value = prevD6Value
Range("E6").Value = prevE6Value
Range("F6").Value = prevF6Value
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
prevD6Value = Range("D6").Value
prevE6Value = Range("E6").Value
prevF6Value = Range("F6").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, fillit As Boolean
If (Not Intersect(Target, Range("B2:D2")) Is Nothing) Or (Not Intersect(Target, Range("D6:F6")) Is Nothing) Then 'a change made in Range 1 or Range 2
fillit = False
For Each r In Range("B2:D2") 'is there data in any of this range?
If r <> "" Then
fillit = True
End If
Next r
If Not Intersect(Target, Range("B2:D2")) Is Nothing Then ' if change is being made in range 1
If fillit Then ' if so then color it
Range("D6:F6").Interior.ColorIndex = 3
Else
Range("D6:F6").Interior.ColorIndex = -4142
End If
Else
If Not Intersect(Target, Range("D6:F6")) Is Nothing Then 'making a change in Range 2 - check if that's ok
If fillit Then 'there is something in Range 1 - so don't allow this change
Application.EnableEvents = False 'so undo doesn't recurse
Application.Undo
Application.EnableEvents = True
Else
'do nothing
End If
End If
End If
End If
End Sub
Dim prevVals() As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, fillit As Boolean
If (Not Intersect(Target, Range("B2:D2")) Is Nothing) Or (Not Intersect(Target, Range("D6:F6")) Is Nothing) Then 'a change made in Range 1 or Range 2
fillit = False
For Each r In Range("B2:D2") 'is there data in any of this range?
If r <> "" Then
fillit = True
End If
Next r
If Not Intersect(Target, Range("B2:D2")) Is Nothing Then ' if change is being made in range 1
If fillit Then ' if so then color it
Range("D6:F6").Interior.ColorIndex = 3
Else
Range("D6:F6").Interior.ColorIndex = -4142
End If
Else
If Not Intersect(Target, Range("D6:F6")) Is Nothing Then 'making a change in Range 2 - check if that's ok
If fillit Then 'there is something in Range 1 - so don't allow this change
Application.EnableEvents = False 'so undo doesn't recurse
Range("D6:F6") = prevVals
Application.EnableEvents = True
Else
'do nothing
End If
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
prevVals = Range("D6:F6")
End Sub
Option Explicit
Private Const sPWD As String = ""
Private Const sInputRange As String = "B2:D2"
Private Const sOutputRange As String = "D6:F6"
Private Const iColorIndex As Long = 3
Dim vDVal As Variant
Dim vEVal As Variant
Dim vFVal As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
'Dimension variables
Dim rCell As Range
'Checks for single cell entry only
If Target.Cells.Count > 1 Then Exit Sub
'Checks to see if the target cell is in the specified input range
If Intersect(Target, Me.Range(sInputRange)) Is Nothing Then
'Checks to see if the target cell is in the specified output range
If Not Intersect(Target, Me.Range(sOutputRange)) Is Nothing Then
'Checks to see if there is any data in the input range
If WorksheetFunction.CountA(Me.Range(sInputRange)) <> 0 Then
'If so, put values back to what they were
Application.EnableEvents = False
Me.Unprotect sPWD
Me.Range("D6").Value = vDVal
Me.Range("E6").Value = vEVal
Me.Range("F6").Value = vFVal
Me.Protect sPWD
Application.EnableEvents = True
End If
Else
Exit Sub
End If
Exit Sub
End If
'Turn off events
Application.EnableEvents = False
'Checks if anything is in the input range
Select Case WorksheetFunction.CountA(Me.Range(sInputRange))
Case Is = 0
'If not, clear out coloring
Me.Range(sOutputRange).Interior.ColorIndex = 0
Me.Range("D6").Locked = False
Me.Range("E6").Locked = False
Me.Range("F6").Locked = False
Case Is = 1
'If so, change the color of the output cells
Me.Range(sOutputRange).Interior.ColorIndex = iColorIndex
Case Else
'Another value was attempted to put into the input range, put
'everything back where it was, clearing the value and giving the user a message
Target.ClearContents
Me.Unprotect sPWD
Me.Range("D6").Value = vDVal
Me.Range("E6").Value = vEVal
Me.Range("F6").Value = vFVal
Me.Range("D6").Locked = True
Me.Range("E6").Locked = True
Me.Range("F6").Locked = True
Me.Protect sPWD
MsgBox "You can only enter information for one range in " & sInputRange & "!", vbExclamation, "ERROR!"
End Select
'Turn events back on
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Set output range values as variant variables
vDVal = Me.Range("D6").Value
vEVal = Me.Range("E6").Value
vFVal = Me.Range("F6").Value
End Sub
Private Sub Worksheet_SelectionChange(
Dim r As Range
If Not Intersect(Target, Range("B2:D2")) Is Nothing Then
Set r = Range("D6:F6")
If Target <> " " Then
With r
.Interior.ColorIndex = 3
End With
End If
End If
End Sub
Put this in your sheet code module,
Dave