Conditional format a free form shape based on a value

[Kevlar]

Can someone please help with the attached, and code?

I keep getting an error on me.shapes.

I am trying to get the shapes to change colour based on the value in v12:v201 (relative to the key)

Thanks,
Kevin

Private Sub ColorShapes()
           Dim shp As Shape
           Dim ShapeVal As Variant
           Dim PostCodes As Variant
           
           PostCodes = Array("pcPE", "pcCB", "pcIP", "pcNR", "pcCO", "pcSG", "pcMK")
           Application.ScreenUpdating = False
           
           For Each shp In Me.Shapes
               If Len(shp.Name) <= 7 Then
                  For i = 0 To UBound(PostCodes, 1)
                      If shp.Name Like PostCodes(i) & "*" Then
                         ShapeNum = Val(Application.WorksheetFunction.Substitute(shp.Name, PostCodes(i), ""))
                         shpname = shp.Name
                         ' insert postcode reference names here and vlook up to postcode reference names here
                         ShapeVal = Application.Evaluate("=VLOOKUP(" & """" & shpname & """" & " , $u$10:$v$202 , 2 , FALSE)")
                 
                         If Not VBA.IsError(ShapeVal) Then
                         ' insert vkey values here
                         IndexVal = Application.Evaluate("=MATCH(" & ShapeVal & " , $v$5:$v$8 , 1)")
                   
                            ShapeColor = Range("$u$8").Offset(IndexVal - 1).Interior.Color
                 
                            shp.Fill.ForeColor.RGB = ShapeColor
                            shp.Fill.Solid
                            shp.Line.Visible = msoFalse
                         End If
                         Exit For
                      End If
                  Next
               End If
           Next
           
           Application.ScreenUpdating = True
End Sub
[CODE]

 

[NARAYANK991]

Hi ,

See if this is OK.

Narayan

 

[Kevlar]

Works perfectly, thank you Narayan.

Do you know how to make the shapes 50% transparent?

It's linked to the cell colour currently.

Best regards,
K

 

[NARAYANK991]

Hi ,

See if this is OK.

An extra line of code has been added , where the transparency factor is 0.5 ; you can change this value to suit.

Narayan

 

[Kevlar]

This has made my day. Thanks

 

[Kevlar]

Hi Narayan,

I have developed the mapping a bit more and now have at local authority level for England and Wales shapes named beginning with LA_, with an associated percentage and the same key table.

I am unable to upload the file because it is too large (which I do not quite understand because it is less than the other file), but I was hoping you could please kindly help again with the coding.

I made a couple of edits, changing the code from:

• Array("pcPE", to Array("LA_" [This is because as the shapes begin with this LA_(followed by name)]
• The references (vlookup reference and key table references) to the relative areas. [As the local authority is a text string rather than a post code now]
• I also updated "If Len(shp.Name) <= 7 Then" from "<30" however it doesn't seem to be updating. [to account for the increased length]

Any idea why this would be?
Can shoot to you on email if that's appropriate?

Sub shapes1()

Dim shp As Shape
Dim ShapeVal As Variant
Dim PostCodes As Variant

PostCodes = Array("LA_")
Application.ScreenUpdating = False

For Each shp In ActiveSheet.Shapes
If Len(shp.Name) <= 30 Then
For i = 0 To UBound(PostCodes, 1)
If shp.Name Like LCase(PostCodes(i)) & "*" Then
ShapeNum = Val(Application.WorksheetFunction.Substitute(shp.Name, PostCodes(i), ""))
shpname = shp.Name
' insert postcode reference names here and vlook up to postcode reference names here
ShapeVal = Application.Evaluate("=VLOOKUP(" & """" & shpname & """" & " , $aq$17:$ar$360 , 2 , FALSE)")

If Not VBA.IsError(ShapeVal) Then
' insert vkey values here
IndexVal = Application.Evaluate("=MATCH(" & ShapeVal & " , $ar$5:$ar$14 , 1)")
If Not VBA.IsError(IndexVal) Then

ShapeColor = Range("$aq$5").Offset(IndexVal - 1).Interior.Color

With shp
.Fill.ForeColor.RGB = ShapeColor
.Fill.Solid
.Fill.Transparency = 0.6
.Line.Visible = msoFalse
End With
End If
End If
Exit For
End If
Next
End If
Next

Application.ScreenUpdating = True
End Sub

[code]

Thanks,
Kevin

 

[NARAYANK991]

Hi ,

It would help if the workbook with the shapes were available ; can you try uploading it in a PM (conversation) ?

If not , send it to me at :

narayank1026 [at] gmail [dot] com

Narayan

 

[Kevlar]

Apologies Narayan, I was having some issues uploading the file. I have sent the file to the email provided by yourself. Thank you. K

 

[NARAYANK991]

Hi ,

See your file now.

The problem was the use of the LCase function.

Narayan