Format picture based on cell value

[Betsy Simpkins]

Hello all!

I'm trying to figure out how to use a picture to illustrate the % of college degree completions in Oregon. I would like to format a picture, say the level of transparency, depending on the % completion in another cell. So, for example, if I crop the picture in quarters, and the completion rate is only 50% in cell A1, I would like the bottom 2 quarters to be in full color, and the top 2 quarters to be 40% transparent.

Is this possible? And if so...can you help me with the code?

Thanks!

[kev_]

Welcome to the forum Betsy

Try the attached file

You must to add the pictures into the worksheet in a particular way to allow them to be made transparent - I will explain this later if the macro below is doing what you want. (There is a second macro in the workbook which will become relevant then)


There are 4 images on Sheet1 - which are manipulated
Change the value in cell A1 and then hit {CTRL} + t to run the macro
Try any percentage between 0 and 100
To make it more obvious I set the transparency level to 70%
You can set it to whatever you want, if you amend the value of t in this line:

   t = 0.7

The macro begins by setting all the images to the transparency level equal to the value of "t", then looks to value in cell A1 and to set transparency to 0 as determined by %complete

Sub TransparentShapeInQuarters()
    Dim ws As Worksheet
    Dim PerCentComplete As Double, t As Double
    Dim picArray
    Set ws = Sheets("Sheet1")
    Dim a As Integer
'set transparency value
    t = 0.7
'set default value for variable "a" 
    a = 99
'put picture names in an array
    picArray = Array("Boat 25%", "Boat 50%", "Boat 75%", "Boat 100%")

    With ws
'where to find percentage complete
        PerCentComplete = .Range("A1").Value
        
'make all 4 quarters partially transparent
        For Each shp In picArray
            .Shapes(shp).Select
            With Selection.ShapeRange.Fill
            .Transparency = t
            End With
        Next shp

'identify items to clear transparency
        Select Case PerCentComplete * 100
            
            Case 25 To 49
                a = 0
            Case 50 To 74
                a = 1
            Case 75 To 99
                a = 2
            Case 100
                a = 3
            Case Else
                Exit Sub
        End Select

'remove transparency
        For x = 0 To a
            .Shapes(picArray(x)).Select
            With Selection.ShapeRange.Fill
            .Transparency = 0
            End With
        Next x
        
'select cell A1 (cancels shape selection)
        .Range("A1").Select
    End With

End Sub

[kev_]

This is a different approach and is simpler
Open file and amend value in A1
This time the macro is called automatically when the value in cell A1 changes

5 images were created
Each is a complete picture, but a % each of picture has been washed out to create a transparency effect
(0%, 25%, 50%, 75%, 100%)
The 5 pictures sit on top of each other.
The value in cell A1 determines which picture is on top (and is therefore visible)


The change macro sits at worksheet level - right click on name Tab and "View Code"

The code will be posted later IF the annoying firewall lets me!

It is in the attached file if anybody wants to look at it

In desperation here is a picture of the code:

MyCode.jpg

[kev_]

And you could simply use conditional formatting (no code required)
Some examples in attached workbook

Select a cell to which conditional formatting has been applied and
on HOME tab
Conditional Formatting
Manage Rules
choose a Rule
Edit Rule

ConditFormat101.jpg

[Betsy Simpkins]

THANK YOU KEV!! Both of these work perfectly. I would like to know more about adding the pics using your first example. Also I imagine it would be possible to create a macro button to run the Ctrl t, just to reduce the keystrokes?

Thank you SOOOO much!

Betsy

[kev_]

The macro below (not mine, I found it somewhere and adapted it) is already in the file attached to my first post (= post#02)
I created the 4 pictures (exactly the same size), then imported them one at a time into the worksheet using the macro.

It is helpful to give the pictures meaningful names (this is not the filename but the name recognised within Excel)
- I used names Boat 25%, Boat 50%, Boat 75%, Boat 100%

Run the macro with {CTRL} + s

- an input box pops up asking for a meaningful name (not the filename).
- overwrite ??? with anything you like but do not leave it blank
(I have not put any checks in to check for invalid characters - so use sensible normal letters and numbers - otherwise the VBA may crash later in the code)
- navigate to the appropriate folder and find the file with the first picture.
- the picture should appear in your sheet
- repeat for the other pictures
- move the pictures to where you want them

The 100,100 are x and y co-ordinates for left corner of picture
The 100,50 are the width and height of the picture

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 100, 50).Select

Good luck! Come back with any further questions
Kev

Sub AddPicThatCanBeMadeTransparent()

    Dim FileSpec As String
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 100, 50).Select
    Selection.Name = Application.InputBox("Enter a Picture Name for VBA", "Name Picture", "???", , , , , 2)
    FileSpec = Application.GetOpenFilename()
    
    With Selection.ShapeRange.Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 0#
            .Visible = msoFalse
            .ForeColor.SchemeColor = 64
            .BackColor.RGB = RGB(255, 255, 255)
    End With
    On Error GoTo FileNotSelected
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 255, 255)
        .BackColor.RGB = RGB(255, 255, 255)
        .UserPicture FileSpec
        .Transparency = 0.7
    End With
Exit Sub

[Betsy Simpkins]

Thanks again Kev....this is exactly what I needed and I learned a lot too. So I can customize the next one. Thank you for being so helpful!

Betsy

[kev_]

You are welcome

Feel free to click on * to add reputation if you are happy with help given

Also if your original question is answered please click on Thread Tools (top of thread) and mark thread as solved (keeps things tidy)
But you can still ask further questions after that if you need some associated help.
Kev

[Betsy Simpkins]

Excellent! I will do both of those. Thanks for walking me through this...first time on forum! But...I'm sure I'll be back since I seem to say "I KNOW Excel SHOULD be able to do this"...like every day!

Thanks again, really appreciate you!