Auto Cell Color using VB

[TNfisherman]

I am trying to auto color cells using this VB code.



Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer

If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
Select Case Target
Case 1
icolor = 6
Case 2
icolor = 12
Case 3
icolor = 7
Case 4
icolor = 53
Case 5
icolor = 15
Case 6
icolor = 42
Case 7
icolor = 1
Case 8
icolor = 20
Case 9
icolor = 30
Case 10
icolor = 40
Case 11
icolor = 51
Case 12
icolor = 14

Case Else
'Whatever
End Select

Target.Interior.ColorIndex = icolor
End If

End Sub

The problem I am having is I have to either hard code in data to change the
color of the cell or I can only copy data into cells one cell at a time to
change the color. What I would like to do is copy data that is on multiple
rows and past it to the work sheet with the VB code and have all of those
cells auto color to my specified colors. I am getting a Debug error stating
"Run time error '13' Type Mismatch" Any help will be greatly appreciated.

 

[Dave Peterson]

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iColor As Long
Dim myRngToInspect As Range
Dim myIntersect As Range
Dim myCell As Range

Set myRngToInspect = Me.Range("A1:A100")
Set myIntersect = Intersect(myRngToInspect, Target)

If myIntersect Is Nothing Then
'do nothing
Else
For Each myCell In myIntersect.Cells

Select Case myCell.Value
Case 1: iColor = 6
Case 2: iColor = 12
Case 3: iColor = 7
Case 4: iColor = 53
Case 5: iColor = 15
Case 6: iColor = 42
Case 7: iColor = 1
Case 8: iColor = 20
Case 9: iColor = 30
Case 10: iColor = 40
Case 11: iColor = 51
Case 12: iColor = 14
Case Else
iColor = -99
End Select

If iColor = -99 Then
'do nothing
Else
myCell.Interior.ColorIndex = iColor
End If
Next myCell

End If

End Sub

 

[Gary''s Student]

One way is to re-paint all the colors in A1 thru A100, regardless of which
specific cell in that range is the one that actually changed:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer
Set r = Range("A1:A100")
If Intersect(Target, r) Is Nothing Then Exit Sub
For Each rr In r

Select Case rr.Value
Case 1
icolor = 6
Case 2
icolor = 12
Case 3
icolor = 7
Case 4
icolor = 53
Case 5
icolor = 15
Case 6
icolor = 42
Case 7
icolor = 1
Case 8
icolor = 20
Case 9
icolor = 30
Case 10
icolor = 40
Case 11
icolor = 51
Case 12
icolor = 14

Case Else
'Whatever
End Select

rr.Interior.ColorIndex = icolor
Next
End Sub

 

[TNfisherman]

I am actually only wanting to color one cell at a time. This code is
coloring the selected cell along with all cells below and to the left of the
selected cell the same color. Any suggestions?

 

[TNfisherman]

This worked realy well! The only thing I would asked to be changed is with
this code I have to make sure to paste special-values only. Otherwise if I
am trying to paste a formula it gives zero values which is a false color.
Any ideas?