Apply color to shapes using the color of other cells

[ruliann]

Hi
I'm trying to color shapes from the filling background of several other cells (themselves located on another sheet than the shape).

• The shape "Pa1" (located on sheet "gif") would successively have the color of cell A1, then cell B1, then C3, then A2, then B2, then C2, then A3, B3, and C3 (all on the specific sheet named "Pa1").
• The shape "Pa2" (located on sheet "gif") would successively have the color of cell A1, then cell B1, then C3, then A2, then B2, then C2, then A3, B3, and C3 (all on the sheet named "Pa2").
• The shape "Tot1" (located on sheet "gif") would successively have the color of cell A1, then cell B1, then C3, then A2, then B2, then C2, then A3, B3, and C3 (all on the sheet named "Tot1").

Do you have an example to show me?

> my file has 50 shapes to color on the “gif” sheet
> each color to use is located on a sheet which has the same name as a shape
> on each of these sheets, there are 100 columns and 30 lines (range A1:CU30) of colors to use successively (to create a visual animation)

 

[sxhall]

Hi ruliann,


The code below will allow for the above, if I've read it correctly.

• Sheet 'gif' has 50 shapes - note code will run for any number of shapes
• There is sheet with the same name as each of the shapes
• You want start colouring them from cell A1 with the last cell being CU30
  • Will go across the Row first - Column A to CU
  • Will then go to the next row - Rows 1 to 100

You have put 'succesively to create an animation', Excel will run through the code and not show anything at the end. To get round this I have added in a wait of 1 second at the end of each cycle of colouring the shapes so that it shows the changes of colours.

The code will run for every shape on sheet 'gif', any shape that does not have a sheet named after it will be skipped.

Sub ColourShapes()

Dim i
Dim ii

Dim MyCol As Integer
Dim MyRow As Integer

Dim ShpName As String
Dim ShtName As String

Dim CellRGB As Long
Dim R As Long
Dim G As Long
Dim B As Long

Sheets("gif").Activate

For i = 1 To 100  'change to required number of columns

MyCol = i

    For ii = 1 To 30  'change to required number of rows
    
    MyRow = ii
    
        For Each ActShp In ActiveSheet.Shapes ' Start of looping through all shapes on sheet "gif"
        
        With ActShp
        ShpName = ActShp.Name
        ShtName = ActShp.Name
        End With
        
            For Each Worksheet In ThisWorkbook.Worksheets ' Start of checking to make sure there is a sheet named after the shape
            If Worksheet.Name = ShtName Then
                    
                CellRGB = Sheets(ShtName).Cells(MyCol, MyRow).Interior.Color
                R = CellRGB Mod 256
                G = CellRGB \ 256 Mod 256
                B = CellRGB \ 65536 Mod 256
            
                ActiveSheet.Shapes.Range(Array(ShpName)).Select
                With Selection.ShapeRange.Fill
                    .ForeColor.RGB = RGB(R, G, B)
                End With
                WorksheetExists = False
            
            End If
            Next Worksheet

        Next ActShp
    
    Application.Wait (Now + TimeValue("0:00:01")) 'wait 1 second before going through the next loop of rows
    
    Next ii
    
Next i

End Sub

 

[ruliann]

@sxhall :
thank you very much for your interest in my post

Is this a problem if the colors of the range (A1:CU30) come from conditional formatting?

 

[sxhall]

It would have been with the above code!

However a quick update and the below will work with colours of conditionally formatted cells as well.

Have tested it on my small test file and works.

Sub ColourShapes()

Dim i
Dim ii

Dim MyCol As Integer
Dim MyRow As Integer

Dim ShpName As String
Dim ShtName As String

Dim CellRGB As Long
Dim R As Long
Dim G As Long
Dim B As Long

Sheets("gif").Activate

For i = 1 To 3 'change to required number of columns

MyCol = i

    For ii = 1 To 3 'change to required number of rows
    
    MyRow = ii
    
        For Each ActShp In ActiveSheet.Shapes ' Start of looping through all shapes on sheet "gif"
        
        With ActShp
        ShpName = ActShp.Name
        ShtName = ActShp.Name
        End With
        
            For Each Worksheet In ThisWorkbook.Worksheets ' Start of checking to make sure there is a sheet named after the shape
            If Worksheet.Name = ShtName Then
                    
                CellRGB = Sheets(ShtName).Cells(MyCol, MyRow).DisplayFormat.Interior.Color
                R = CellRGB Mod 256
                G = CellRGB \ 256 Mod 256
                B = CellRGB \ 65536 Mod 256
            
                ActiveSheet.Shapes.Range(Array(ShpName)).Select
                With Selection.ShapeRange.Fill
                    .ForeColor.RGB = RGB(R, G, B)
                End With
                WorksheetExists = False
            
            End If
            Next Worksheet

        Next ActShp
    
    Application.Wait (Now + TimeValue("0:00:02")) 'wait 2 seconds before going through the next loop of rows
    
    Next ii
    
Next i

End Sub

 

[ruliann]

@sxhall :
your code works as described on a "blank" file, but I'm having more trouble applying it to my file.
can i submit my file to you so that you can tell me if it's possible for the code to work?

 

[sxhall]

You can, will take a look when I'm back in the office

 

[ruliann]

@sxhall : it's fine
As I'm new to the forum, I'm not sure which add-in to use to attach a message. I'm following the instructions on this page using a DropBox link.
It's a Zip file that contains the Excel file, and a gif file that illustrates the animation I want to make (dropbox link).

let me know if you don't like the way I've done it

 

[sxhall]

Hi ruliann,

Downloaded the file successfully and have updated some of the workbook and the code, see the below.

A few things I found...

• Code was looking for sheet 'animation' in the file you sent over - changed this to 'gif' in the code.
• Shape names were not correctly named as per sheets, although they had 'TH1' etc. in the shape as text the actual names were listed as 'ZoneTexte1' etc. - renamed them to match the tab names (image below shows some renamed shapes in the 'Selection pane’ against the orignal names).
• Sheets for Ext2 and Pal1 had tables on them starting on row 3/4 not row 26 so were being missed by the code - moved these tables down so the data starts on row 26 the same as the TH1-25 sheets, code captures these now.

Also I have changed the code as I it had running through columns then rows not rows then columns. Code now goes C26 to CT26 and then to the next row and continues.

With regard to the time, you can add in a pause of less than a second using 'sleep' in VBA. However, I've played with several different methods and although they work I did not manage to get it to show a refresh of the screen with the shapes changing colour!

Suggestions would be ...

Post another thread on this forum asking how to pause for 0.25 of a second and refresh the screen so the colour change shows in the shapes.​

or...​

Leave the 1 second pause in but play with the speed of the file being played back, not sure if this is possible for the output you are creating.​

Have uploaded the file to DropBox for you

sxhall

Names in Selection Pane..

Code, with updates, as in the workbook...

Sub ColourShapes()

Dim MyCol As Integer
Dim MyRow As Integer

Dim ShpName As String
Dim ShtName As String

Dim CellRGB As Long
Dim R As Long
Dim G As Long
Dim B As Long

Sheets("gif").Activate 'was looking for sheet 'animation', changed to sheet 'gif'

For Rs = 26 To 46 'change to required number of columns

MyRow = Rs

    For Cs = 3 To 96 'change to required number of rows
    
    MyCol = Cs

        For Each ActShp In ActiveSheet.Shapes ' Start of looping through all shapes on sheet "gif"
              
        With ActShp
        ShpName = ActShp.Name
        ShtName = ActShp.Name
        End With

            For Each Worksheet In ThisWorkbook.Worksheets ' Start of checking to make sure there is a sheet named after the shape
            If Worksheet.Name = ShtName Then
                    
                CellRGB = Sheets(ShtName).cells(MyRow, MyCol).DisplayFormat.Interior.Color
                R = CellRGB Mod 256
                G = CellRGB \ 256 Mod 256
                B = CellRGB \ 65536 Mod 256
                
                ActiveSheet.Shapes.Range(Array(ShpName)).Select
                With Selection.ShapeRange.Fill
                    .ForeColor.RGB = RGB(R, G, B)
                End With
                WorksheetExists = False
            
            End If
            Next Worksheet

        Next ActShp
        
    Range("Z15").Activate
    Application.Wait (Now + TimeValue("0:00:01")) 'wait 1 seconds before going through the next loop of rows
    
    Next Cs
    
Next Rs

End Sub

 

[ruliann]

Hi @sxhall, thank you very much for this great work! it helps me understand that you indicated that I had made mistakes.

I m going to follow your suggestions, as well as adding the day and time (analog or digit clock) in a cell in order to have a visual cue when the animation is launched