Colored Shapes based on cell value

[louww]

Any help would be appreciated.

I would like to create a color heatmap with shapes. The shapes should be linked to a cell value and a certain color according to value (1,2,3,4,5)

I've tried to adapt p45calc's code with no luck:

[VBA]Private Sub Worksheet_Change(ByVal Target As range)
With Target
If IsNumeric(.Value) And .Value > 1 <= 2 Then
Set TheCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, _
.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
' Optional stuff:
With TheCircle
LockAspectRatio = msoTrue
With .Line
Weight = 3.5
.ForeColor.SchemeColor = 10
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Solid
.ForeColor.SchemeColor = 43
.Transparency = 0.69
End With
End With
End If
End With
End Sub[/VBA]

[Bob Phillips]

[vba]
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If IsNumeric(.Value) And .Value > 1 <= 5 Then
Set TheCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, _
.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
' Optional stuff:
With TheCircle
LockAspectRatio = msoTrue
With .Line
Weight = 3.5
.ForeColor.SchemeColor = 10
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Solid
Select Case Target.Value
Case 1: .ForeColor.RGB = Me.Range("M1").Interior.Color
Case 2: .ForeColor.RGB = Me.Range("M2").Interior.Color
Case 3: .ForeColor.RGB = Me.Range("M3").Interior.Color
Case 4: .ForeColor.RGB = Me.Range("M4").Interior.Color
Case 5: .ForeColor.RGB = Me.Range("M5").Interior.Color
End Select
.Transparency = 0.69
End With
End With
End If
End With
End Sub
[/vba]

[louww]

Brilliant , thanks xld

the case statements can also act as the legend

Last q, is there a way to automaticaaly size the shape a bit smaller than cell (to overcome shapes being to close to each other)?

[Bob Phillips]

[vba]

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If IsNumeric(.Value) And .Value > 1 <= 5 Then
Set TheCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, _
Left:=.Left + 2, _
Top:=.Top + 2, _
Width:=.Width - 4, _
Height:=.Height - 4)
' Optional stuff:
With TheCircle
LockAspectRatio = msoTrue
With .Line
Weight = 3.5
.ForeColor.SchemeColor = 10
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Solid
Select Case Target.Value
Case 1: .ForeColor.RGB = Me.Range("M1").Interior.Color
Case 2: .ForeColor.RGB = Me.Range("M2").Interior.Color
Case 3: .ForeColor.RGB = Me.Range("M3").Interior.Color
Case 4: .ForeColor.RGB = Me.Range("M4").Interior.Color
Case 5: .ForeColor.RGB = Me.Range("M5").Interior.Color
End Select
.Transparency = 0.69
End With
End With
End If
End With
End Sub
[/vba]

[louww]

thanks works excellently!