Help with If Not Intersect

[derek]

Excel 2000
With a previous question and your help I'm up and running
with the code below. But I need a last bit of help please
to find away round a glitch..
Users enter data into the sheet within a range of C5:H33.
For ease they sometime copy and paste part of a row into
the next row but sometime paste it into the wrong cell.
The result is the red/bold format if present in the F5:F33
(from the code below) is transfered to another cell. How
can I ensure that all other cells other than the F5:F33
range remains black and normal when data is enterd either
directly or copied from a cell with red/bold format?

Private Sub workbook_sheetchange(ByVal sh As Object, ByVal
Target As Range)
On Error Resume Next

If Not Intersect(Target, Range("f5:f33")) Is Nothing Then
If Target.Value >= 0.5 Then
Target.Font.ColorIndex = 3: Target.Font.FontStyle = "bold"
Else
Target.Font.ColorIndex = 1: Target.Font.FontStyle
= "normal"
End If
End If
End Sub

TIA Derek..

 

[Bob Phillips]

Derek,

Try this, It's a bit more intensive, but works

Private Sub workbook_sheetchange(ByVal sh As Object, ByVal Target As Range)
Dim cell As Range
On Error Resume Next

For Each cell In Target
If Not Intersect(cell, Range("f5:f33")) Is Nothing Then
If cell.Value >= 0.5 Then
cell.Font.ColorIndex = 3
cell.Font.FontStyle = "bold"
Else
cell.Font.ColorIndex = 1
cell.Font.FontStyle = "normal"
End If
End If
Next cell
End Sub

 

[derek]

Bob thanks for the quick response, but I'm still stuck,
I'm sure its me not explaing it right. You code works
fine but if I copy a cell from the range F5:F33 that has a
value of 0.6 (Its now red and bold because of your code)
that format is applied when pasted to say cell C5. I need
it to be black/normal. Users of my sheet are
occaisionally accidently copying and pasting a cell from
the F5:F33 range elsewhere in the sheet and what should be
black is formatted red.

TIA derek..

 

[Tom Ogilvy]

alter it to this:

rivate Sub workbook_sheetchange(ByVal sh As Object, ByVal Target As Range)
Dim cell As Range
On Error Resume Next

For Each cell In Target
If Not Intersect(cell, Range("f5:f33")) Is Nothing Then
If cell.Value >= 0.5 Then
cell.Font.ColorIndex = 3
cell.Font.FontStyle = "bold"
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.FontStyle = "normal"
End If
Else
cell.Font.ColorIndex = xlAutomatic
cell.Font.FontStyle = "normal"

End If
Next cell
End Sub


Regards,
Tom Ogilvy

 

[BrianB]

It is really impossible to outguess your users, they will win at every
attempt <grin>.

I would add code to re-format the range each time, or just before the
workbook is closed.

Regards
BrianB
====================================================

 

[Leo Heuser]

Derek

Here´s another approach.

The below function returns the complementary range
of two ranges. If you have two ranges A an B, then
A's complement in regard to B is all the cells in A, which are
not in B. This function may come up handy in several situations.

In your example SuperRange is C5:H33 and SubRange is F5:F33,
so the complementrange is C5:E33 + G5:H33, the range you want
to keep its formatting.

This setup will do the job:

Place the function in a general module.

Function ComplementaryRange(SuperRange As Range, _
SubRange As Range) As Range
'Leo Heuser, 11 July 2003
Dim ComplementRange As Range
Dim Counter As Long
Dim PartRange(1 To 4) As Range

On Error Resume Next

Set SubRange = Intersect(SuperRange, SubRange)

With SuperRange
Set PartRange(1) = Cells(.Row, .Column).Resize(SubRange.Row - _
.Row, .Columns.Count)

Set PartRange(2) = Cells(SubRange.Row, .Column). _
Resize(SubRange.Rows.Count, SubRange.Column - .Column)

Set PartRange(3) = Cells(SubRange.Row, SubRange.Column + _
SubRange.Columns.Count). _
Resize(SubRange.Rows.Count, .Columns.Count - (SubRange.Column -
_
.Column + SubRange.Columns.Count))

Set PartRange(4) = Cells(SubRange.Row + SubRange.Rows.Count,
..Column). _
Resize(.Rows.Count - (SubRange.Row - .Row +
SubRange.Rows.Count), _
.Columns.Count)
End With

For Counter = 1 To 4
If Not PartRange(Counter) Is Nothing Then
If ComplementRange Is Nothing Then
Set ComplementRange = PartRange(Counter)
Else
Set ComplementRange = Union(ComplementRange, _
PartRange(Counter))
End If
End If
Next Counter

Set ComplementaryRange = ComplementRange

On Error Goto 0
End Function


Make the following adjustments to your code:

Private Sub workbook_sheetchange(ByVal sh As Object, ByVal Target As Range)
Dim ComplementRange As Range

On Error Resume Next

If Not Intersect(Target, Range("f5:f33")) Is Nothing Then
If Target.Value >= 0.5 Then
Target.Font.ColorIndex = 3: Target.Font.FontStyle = "bold"
Else
Target.Font.ColorIndex = 1: Target.Font.FontStyle = "normal"
End If

Set ComplementRange =
ComplementaryRange(Range("C5:H33"),Range("F5:F33"))

With ComplementRange.Font
.ColorIndex = 1
.FontStyle = "normal"
End With

End If
End Sub

--
Best Regards
Leo Heuser
MVP Excel

Followup to newsgroup only, please.

 

[Leo Heuser]

Sorry about the word-wrapping. Here's one
without:

Function ComplementaryRange(SuperRange As Range, _
SubRange As Range) As Range
'Leo Heuser, 11 July 2003
Dim ComplementRange As Range
Dim Counter As Long
Dim PartRange(1 To 4) As Range

On Error Resume Next

Set SubRange = Intersect(SuperRange, SubRange)
With SuperRange
Set PartRange(1) = Cells(.Row, .Column). _
Resize(SubRange.Row - .Row, .Columns.Count)

Set PartRange(2) = Cells(SubRange.Row, .Column). _
Resize(SubRange.Rows.Count, SubRange.Column - .Column)

Set PartRange(3) = Cells(SubRange.Row, SubRange.Column + _
SubRange.Columns.Count). _
Resize(SubRange.Rows.Count, .Columns.Count - _
(SubRange.Column - .Column + SubRange.Columns.Count))

Set PartRange(4) = Cells(SubRange.Row + _
SubRange.Rows.Count, .Column). _
Resize(.Rows.Count - (SubRange.Row - .Row + _
SubRange.Rows.Count), .Columns.Count)
End With

For Counter = 1 To 4
If Not PartRange(Counter) Is Nothing Then
If ComplementRange Is Nothing Then
Set ComplementRange = PartRange(Counter)
Else
Set ComplementRange = Union(ComplementRange, _
PartRange(Counter))
End If
End If
Next Counter

Set ComplementaryRange = ComplementRange
End Function

 

[Leo Heuser]

It will not pop up in your present situation, but to cover
all situations (and to make it mathematically correct),
use this version instead.
The only difference is, that if the two ranges have no
cells in common, SuperRange is returned, instead of
an empty range.
I hope this will be the last instalment


Function ComplementaryRange(SuperRange As Range, _
SubRange As Range) As Range
'Leo Heuser, 11 July 2003
Dim ComplementRange As Range
Dim Counter As Long
Dim PartRange(1 To 4) As Range

On Error Resume Next

Set SubRange = Intersect(SuperRange, SubRange)
With SuperRange
Set PartRange(1) = Cells(.Row, .Column). _
Resize(SubRange.Row - .Row, .Columns.Count)

Set PartRange(2) = Cells(SubRange.Row, .Column). _
Resize(SubRange.Rows.Count, SubRange.Column - .Column)

Set PartRange(3) = Cells(SubRange.Row, SubRange.Column + _
SubRange.Columns.Count). _
Resize(SubRange.Rows.Count, .Columns.Count - _
(SubRange.Column - .Column + SubRange.Columns.Count))

Set PartRange(4) = Cells(SubRange.Row + _
SubRange.Rows.Count, .Column). _
Resize(.Rows.Count - (SubRange.Row - .Row + _
SubRange.Rows.Count), .Columns.Count)
End With

For Counter = 1 To 4
If Not PartRange(Counter) Is Nothing Then
If ComplementRange Is Nothing Then
Set ComplementRange = PartRange(Counter)
Else
Set ComplementRange = Union(ComplementRange, _
PartRange(Counter))
End If
End If
Next Counter

If ComplementRange Is Nothing Then
Set ComplementaryRange = SuperRange
Else
Set ComplementaryRange = ComplementRange
End If
End Function