Colour shapes based on cell values in a lookup

Hi

I am having trouble getting a map I created out of shapes to colour each shape in based on table values, I want for instance a shape I have named NR to lookup NR in a table and if the value in column 3 is between £0 and £10,000 to go red, £10,000 and £50,000 yellow, over £50,000 green.

I have found a code on another thread which did part of the work but I cant seem to manipulate it to work my spreadsheet, I am very new to VBA.

The code I have is;

Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
    Dim Zone As Long
    Dim r As Long, g As Long, b As Long
    If Target.Address = "$B$3" Then
    With Worksheets("Map")
        For Each shp In .Shapes
            Zone = WorksheetFunction.VLookup(shp.Name, Worksheets("Map").Range("u4:x130"), 3, False)
            On Error Resume Next
            Select Case Zone
                Case 1
                    r = 255
                    g = 100
                    b = 100
                Case 2
                    r = 100
                    g = 255
                    b = 100
                Case 3
                    r = 100
                    g = 100
                    b = 255
            End Select
            shp.Fill.ForeColor.RGB = RGB(r, g, b)
        Next shp
    End With
    End If
End Sub

as you can see B3 is a dropdown ("Premium" and "Commission") and when changed id like the colours to update, but if possible also move the lookup to;

 Zone = WorksheetFunction.VLookup(shp.Name, Worksheets("Map").Range("u4:x130"), 4, False)

Any help is very appreciated.

Thank you
Dustin

Hi there,

It's difficult to know how to solve your problem without seeing your workbook, but a good starting point would be to remove the line:

    On Error Resume Next

and then you'll know at least at which point your code is encountering the error.

Regards,

Greg M

Hi

Thank you for the response and sorry for my late reply, I had left work, I have made some amendments to the code and managed to get it to colour each shape based on 2 number parameters, but I do need 3 at least, I cant figure out how to code for a value between 5 and 10 as an example, only greater than or less than separate.

I have attached a test version of my file where I have deleted most data and used dummy values for the data left. The code is on the "Map" sheet.

I also still cant figure how to change the lookup parameters based on the dropdown in cell B3 so if it says commission the lookup goes to the 4th column instead of the 3rd and the value parameters change to greather than 50k, less than 10k and 10k - 50k.

Also the line you mention to remove only skips over an error where the code tried to select the dropdown as a shape by the looks of it, so I kept it in to skip that.

Thank you
Dustin

Hi again,

Take a look at the attached workbook and see if it's getting closer to meeting your needs. The column used in the lookup table is now appropriate to whichever of Commission or Premium is selected. The map also uses three colours to designate the different amount ranges.

You'll also see that all of the parameters which relate to the layout of the worksheet have been defined as constant values at the start of the routine - this makes it easier to alter your code in response to any changes in the worksheet layout.

The "Map" worksheet uses the following code:

Sub Worksheet_Change(ByVal Target As Range)

    Const iOFFSET_COMMISSION    As Integer = 4
    Const iOFFSET_PREMIUM       As Integer = 3
    Const sDROPDOWN_ADDRESS     As String = "$B$3"
    Const sDROPDOWN_PREFIX      As String = "Drop Down "
    Const sLOOKUP_RANGE         As String = "T4:W130"
    Const sCOMMISSION           As String = "Commission"
    Const sPREMIUM              As String = "Premium"

    Dim iColumnOffset           As Integer
    Dim rLookupRange            As Range
    Dim Zone                    As Long
    Dim wks                     As Worksheet
    Dim shp                     As Shape
    Dim r                       As Long
    Dim g                       As Long
    Dim b                       As Long

    If Target.Address = sDROPDOWN_ADDRESS Then

        With Me

            For Each shp In .Shapes

                If Left$(shp.Name, Len(sDROPDOWN_PREFIX)) <> sDROPDOWN_PREFIX Then

                    Select Case Target.Value

                           Case Is = sPREMIUM
                                iColumnOffset = iOFFSET_PREMIUM

                           Case Is = sCOMMISSION
                                iColumnOffset = iOFFSET_COMMISSION

                    End Select

                    Set rLookupRange = .Range(sLOOKUP_RANGE)
                    Zone = WorksheetFunction.VLookup(shp.Name, rLookupRange, _
                                                     iColumnOffset, False)

                    Select Case Zone

                           Case Is < 150000
                                r = 255
                                g = 150
                                b = 100

                          Case Is > 300000
                                r = 150
                                g = 200
                                b = 80

                          Case Else
                               r = 255
                               g = 200
                               b = 80

                    End Select

                    shp.Fill.ForeColor.RGB = RGB(r, g, b)

                End If

            Next shp

        End With

    End If

End Sub

I've put in a more specific test for ignoring the DropDown shape. Using "On Error Resume Next" without an accompanying "On Error GoTo 0" is a very dangerous approach, as your code will then ignore ANY errors and can really make a mess of your workbook - especially if objects like ActiveWorkbook, ActiveSheet and ActiveCell are involved!

Hope this helps - please let me know how you get on.

Regards,

Greg M