Getting freeform shapes to change colour corresponding to values in cells

[cg_norman]

Complicated one which is why I am struggling and cant seem to get other suggesstions on this topic to work.

Situation
I have a map of the UK split into 36 zones displayed by 36 freeform shapes on my worksheet. I have a list of 14 teams in a table next to the image to which the zones will be allocated.

Requirements
If possible, I require a map that when zones are allocated to the teams the freeform shape displaying that area would change to the team colour to provide a pictoral representation of assignments.

ie if zone 1, represented by the number 1, is assigned to and entered in the row of team 1 (range O4:S4) the freeform shape covering zone 1 (identified by using the cell reference box which displays "Freeform 80") would change to the colour assigned to team 1.

A team could be assigned up to a maximum of 5 zones so a team's row/ range would run 5 cells.

Also, would like the transparency to be set at 70% so that the map of the uk would still be visible under the freeform shapes.

Would I have to write 36 rules for 14 teams or 14 rules for 36 zones?

Hope that all makes sense. Any help would be appreciated.

 

[pbornemeier]

Is the team to zone range O2:S15? If not, what is the What cells contain the color reference for each Team 1-14 ? What type of reference is it? (Actual color of the cell?, Long representation of the RGB color (65536)), color index number? (number from 1 to 56), ObjectThemeColor identifier (msoThemeColorAccent2))
What cells contain Zone Number to Shape Name Reference ?
Is there any reason that the Zone Number cannot be made to correspond to the shape name? (e.g. Zone 1 represented by Freeform 1)
What should happen if 2 teams are assigned to the same zone?

If the cell sin N2:N15 are colored to represent the teams and
the team to zone assignments are in O2:S15 and
the shapes are named Freeform 1 to Freeform 36
and data entry for those cells are limited to whole numbers 1 to 36 and blanks
then try this code

This code should be placed on the code page of the worksheet holding the team assignments.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    'Use data validation to restrict inputs to Range("O2:S15") to be whole numbers from 1 to 36, blanks OK
    'Team Names are in N2:N15
    'Team colors are the color of the cell the team name is in
    
    Dim rngCell As Range
    Dim oFound As Object
    Dim lColor As Long
    Dim sShapeName As String
    Dim lCount As Long
    
    For Each rngCell In Target
        If Not Intersect(rngCell, Range("O2:S15")) Is Nothing Then
            'Make sure number is not already used
            lCount = Application.WorksheetFunction.CountIf(Range("O2:S15"), rngCell.Value)
            If rngCell.Value = vbNullString Then
                ResetColors
            End If
            
            If lCount < 2 And rngCell.Value <> vbNullString Then
                'Not blank and number not already used
                lColor = Cells(rngCell.Row, "N").Interior.Color
                sShapeName = "Freeform " & rngCell.Value
                ChangeShapeColor sShapeName, lColor
            Else
                If rngCell.Value <> vbNullString Then MsgBox "That zone is already assigned to another team."
            End If
    




        
        End If
    Next
    
    Set oFound = Nothing
End Sub

Sub ResetColors()
    
    Dim lShapeNumber As Long
    Dim lCount As Long
    
    For lShapeNumber = 1 To 36
        lCount = Application.WorksheetFunction.CountIf(Range("O2:S15"), lShapeNumber)
        If lCount <> 1 Then ChangeShapeColor "Freeform " & CStr(lShapeNumber), -4142
    Next
    
End Sub

Sub ChangeShapeColor(sShapeName As String, lColor As Long)

'    Dim lColor As Long
'    Dim sShapeName As String
'    lColor = 65535
'    sShapeName = "Freeform 1"
    
    With ActiveSheet.Shapes(sShapeName)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = 0
            .Transparency = IIf(lColor = -4142, 1, 0.7)
            .Solid
        End With
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .Transparency = IIf(lColor = -4142, 1, 0.7)
        End With
    End With
    
End Sub

Excel Workbook
	N	O	P	Q	R	S
2	Team 1	14	15	*	*	*
3	Team 2	1	*	*	*	*
4	Team 3	2	*	16	*	*
5	Team 4	3	*	17	*	*
6	Team 5	4	*	*	18	*
7	Team 6	5	*	*	19	*
8	Team 7	6	*	*	20	*
9	Team 8	7	*	*	21	*
10	Team 9	8	*	*	*	*
11	Team 10	9	*	*	*	*
12	Team 11	10	*	23	22	*
13	Team 12	11	*	*	*	*
14	Team 13	12	*	*	*	*
15	Team 14	13	*	*	*	24
Sheet1

 

[cg_norman]

When I ran the code the Macro window popped up with the Macro name "ResetColors". I hit run then it reset all the colour fills that where already there but it doesnt want to run the ChangeShapeColor.

To confirm;
Team cells range is N3:N16 and each is filled a colour from the standard fill pallette
Zone assignment range is O3:S16 (apologies for the previous incorrect reference, the code was ammended before applying)#
All the freeform shapes have been renamed from "Freeform 1" to "Freeform 36"
I have applied the code to the wooksheet with the teams on it.
I have validated the data area so only whole numbers between 1-36 can be entered

In response to your question, a zone will be only assigned to one team.

Am I missing anything?

 

[pbornemeier]

If the code is in the codepage of the worksheet that holds the table (not in a standard module or in the ThisWorkbook codepage) then when any cell in that worksheet is changed, this subroutine Private Sub Worksheet_Change(ByVal Target As Range) will trigger. You do not have to do anything else to start the code working.

If there are numbers already in the input area, it will not change those colors. Highlight the input area, copy the data to another area, clear the input area and copy/paste the cells back in. that will trigger the code

Code is modified slightly and many comments added. It will stop to allow you to check to see if it is working. Overwrite all of the old code on the codepage of the worksheet that contains the input worksheet

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'This code is triggered when any cell on the its worksheet is changed
    'Target' is the range of cells that were just changed

    'Use data validation to restrict inputs to Range("O3:S16") to be whole numbers from 1 to 36, blanks OK
    'Team Names are in N3:N16
    'Team colors are the color of the cell the team name is in
    
    Dim rngCell As Range
    Dim oFound As Object
    Dim lColor As Long
    Dim sShapeName As String
    Dim lCount As Long
    
    Stop 'Uncomment this line to test to see if the code is being triggered when a cell is changed
    '       then reduce this window to about half size so you can see the worksheet as well and
    '       use F8 to single step through the code
    
    For Each rngCell In Target
        'This look examimes each cell that was changed
        If Not Intersect(rngCell, Range("O3:S16")) Is Nothing Then
            'if the cell is in the input range
            'Make sure number is not already used
            
             'Count the number of times the number in the cell appears in the input area
             lCount = Application.WorksheetFunction.CountIf(Range("O3:S16"), rngCell.Value)
            
            If rngCell.Value = vbNullString Then
                'If the cell was changed to empty, the reset all shapes without a number
                'in the input area to no color
                ResetColors
            End If
            
            If lCount < 2 And rngCell.Value <> vbNullString Then
                'Not blank and number not already used, set the color to the column N color of the row of the cell being checked
                lColor = Cells(rngCell.Row, "N").Interior.Color
                sShapeName = "Freeform " & rngCell.Value
                ChangeShapeColor sShapeName, lColor
            Else
                If rngCell.Value <> vbNullString Then MsgBox "That zone is already assigned to another team."
            End If
            
        End If
    Next
    
    Set oFound = Nothing
End Sub

Sub ResetColors()
    'If the number 1 to 36 does not appear in the input range, change the color of the
    '  corresponding shape to no color
    
    Dim lShapeNumber As Long
    Dim lCount As Long
    
    For lShapeNumber = 1 To 36
        lCount = Application.WorksheetFunction.CountIf(Range("O3:S16"), lShapeNumber)
        If lCount <> 1 Then ChangeShapeColor "Freeform " & CStr(lShapeNumber), -4142
    Next
    
End Sub

Sub ChangeShapeColor(sShapeName As String, lColor As Long)

'    Dim lColor As Long
'    Dim sShapeName As String
'    lColor = 65535
'    sShapeName = "Freeform 1"
    
    With ActiveSheet.Shapes(sShapeName)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = 0
            .Transparency = IIf(lColor = -4142, 1, 0.7)
            .Solid
        End With
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .Transparency = IIf(lColor = -4142, 1, 0.7)
        End With
    End With
    
End Sub

"Target" in the above line represents the cell(s) that were just changed

This For...Each loop

For Each rngCell In Target

checks each cell to see if it is in the input range (O3:S16) and if it is

 

[cg_norman]

This is outstanding!!! Greatly appreciated

 

[vmjan02]

If the code is in the codepage of the worksheet that holds the table (not in a standard module or in the ThisWorkbook codepage) then when any cell in that worksheet is changed, this subroutine Private Sub Worksheet_Change(ByVal Target As Range) will trigger. You do not have to do anything else to start the code working.

If there are numbers already in the input area, it will not change those colors. Highlight the input area, copy the data to another area, clear the input area and copy/paste the cells back in. that will trigger the code

Code is modified slightly and many comments added. It will stop to allow you to check to see if it is working. Overwrite all of the old code on the codepage of the worksheet that contains the input worksheet

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'This code is triggered when any cell on the its worksheet is changed
    'Target' is the range of cells that were just changed

    'Use data validation to restrict inputs to Range("O3:S16") to be whole numbers from 1 to 36, blanks OK
    'Team Names are in N3:N16
    'Team colors are the color of the cell the team name is in
   
    Dim rngCell As Range
    Dim oFound As Object
    Dim lColor As Long
    Dim sShapeName As String
    Dim lCount As Long
   
    Stop 'Uncomment this line to test to see if the code is being triggered when a cell is changed
    '       then reduce this window to about half size so you can see the worksheet as well and
    '       use F8 to single step through the code
   
    For Each rngCell In Target
        'This look examimes each cell that was changed
        If Not Intersect(rngCell, Range("O3:S16")) Is Nothing Then
            'if the cell is in the input range
            'Make sure number is not already used
           
             'Count the number of times the number in the cell appears in the input area
             lCount = Application.WorksheetFunction.CountIf(Range("O3:S16"), rngCell.Value)
           
            If rngCell.Value = vbNullString Then
                'If the cell was changed to empty, the reset all shapes without a number
                'in the input area to no color
                ResetColors
            End If
           
            If lCount < 2 And rngCell.Value <> vbNullString Then
                'Not blank and number not already used, set the color to the column N color of the row of the cell being checked
                lColor = Cells(rngCell.Row, "N").Interior.Color
                sShapeName = "Freeform " & rngCell.Value
                ChangeShapeColor sShapeName, lColor
            Else
                If rngCell.Value <> vbNullString Then MsgBox "That zone is already assigned to another team."
            End If
           
        End If
    Next
   
    Set oFound = Nothing
End Sub

Sub ResetColors()
    'If the number 1 to 36 does not appear in the input range, change the color of the
    '  corresponding shape to no color
   
    Dim lShapeNumber As Long
    Dim lCount As Long
   
    For lShapeNumber = 1 To 36
        lCount = Application.WorksheetFunction.CountIf(Range("O3:S16"), lShapeNumber)
        If lCount <> 1 Then ChangeShapeColor "Freeform " & CStr(lShapeNumber), -4142
    Next
   
End Sub

Sub ChangeShapeColor(sShapeName As String, lColor As Long)

'    Dim lColor As Long
'    Dim sShapeName As String
'    lColor = 65535
'    sShapeName = "Freeform 1"
   
    With ActiveSheet.Shapes(sShapeName)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = 0
            .Transparency = IIf(lColor = -4142, 1, 0.7)
            .Solid
        End With
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .Transparency = IIf(lColor = -4142, 1, 0.7)
        End With
    End With
   
End Sub

"Target" in the above line represents the cell(s) that were just changed

This For...Each loop

For Each rngCell In Target

checks each cell to see if it is in the input range (O3:S16) and if it is

Hi
I tried your code but its not working for me
my range is from B1 to B14 and region is in Column A.

Riyadh	109.431​
Makkah	105.826​
Eastern	103.195​
Al Qassim	83.479​
Al Madinah	105.624​
Jazan	47.38​
Aseer	104.02​
Hail	111.292​
Al Jowf	61.826​
Northern Borders	97.132​
Tabuk	109.231​
Najran	66.869​
Al Bahah	175.715​

 

[pbornemeier]

Please post how you changed the code.
Have you named the shapes on the page to match the values in column A?
Do the numbers in column B represent the colors for those shapes?
Have you posted the code on the codepage of the worksheet that contains the shapes?

 

[vmjan02]

this is the table I have

Riyadh	109.43​		RGB	0,176,80		> 70
Makkah	105.826​		RGB	146,208,80		>55 - <=70
Eastern	103.195​		RGB	255,0,0		<55
Al Qassim	83.479​
Al Madinah	105.624​
Jazan	47.382​
Aseer	104.02​
Hail	111.292​
Al Jowf	61.826​
Northern Borders	97.132​
Tabuk	109.231​
Najran	66.869​
Al Bahah	175.715​

the shape name is Freeform 1 to 14 and with respect to this trying to do the need full. more over Ihave change the range to B1 to B14.
Yes the code is correctly placed on worksheet, as on earlier post.

you sueegstion is to change the Freeform 1 to Riyadh ?

 

[vmjan02]

I have changed the code, and this line gives me an error

With ActiveSheet.Shapes(sShapeName)

Private Sub Worksheet_Change(ByVal Target As Range)

    'Use data validation to restrict inputs to Range("O2:S15") to be whole numbers from 1 to 36, blanks OK
    'Team Names are in N2:N15
    'Team colors are the color of the cell the team name is in

    Dim rngCell As Range
    Dim oFound As Object
    Dim lColor As Long
    Dim sShapeName As String
    Dim lCount As Long

    For Each rngCell In Target
        If Not Intersect(rngCell, Range("B1:B13")) Is Nothing Then
            'Make sure number is not already used
            lCount = Application.WorksheetFunction.CountIf(Range("B1:B13"), rngCell.Value)
            If rngCell.Value = vbNullString Then
                ResetColors
            End If

            If lCount < 2 And rngCell.Value <> vbNullString Then
                'Not blank and number not already used
                lColor = Cells(rngCell.Row, "B").Interior.Color
                sShapeName = "Freeform " & rngCell.Value
                ChangeShapeColor sShapeName, lColor
            Else
                If rngCell.Value <> vbNullString Then MsgBox "That zone is already assigned to another team."
            End If






        End If
    Next

    Set oFound = Nothing
End Sub

Sub ResetColors()

    Dim lShapeNumber As Long
    Dim lCount As Long

    For lShapeNumber = 1 To 36
        lCount = Application.WorksheetFunction.CountIf(Range("B1:B13"), lShapeNumber)
        If lCount <> 1 Then ChangeShapeColor "Freeform " & CStr(lShapeNumber), -4142
    Next

End Sub

Sub ChangeShapeColor(sShapeName As String, lColor As Long)

'    Dim lColor As Long
'    Dim sShapeName As String
'    lColor = 65535
'    sShapeName = "Freeform 1"

    With ActiveSheet.Shapes(sShapeName)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = 0
            .Transparency = IIf(lColor = -4142, 1, 0.7)
            .Solid
        End With
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = lColor
            .Transparency = IIf(lColor = -4142, 1, 0.7)
        End With
    End With

End Sub

 

[pbornemeier]

The shapes should be renamed to match the names in column A. Will comment on code next post.