Streamline this VBA

[Atholl]

Hi all,

The following code works a kind of traffic light system which colours a shape and brings it to the front depending on the contents of a cell (K18). The code works perfectly for my 28 shapes but I feel I could streamline this as it's veeerrrrrry long winded! Unfortunately, everything I've tried thus far hasn't worked.

Has anyone any suggestions?

Atholl

If Worksheets("Summary").Range("K18") = "A" Then
     ActiveSheet.Shapes("SHAPE 1").ZOrder msoBringToFront
     ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 12
     ActiveSheet.Shapes("SHAPE 1").Fill.Solid
     ActiveSheet.Shapes("SHAPE 1").Fill.Transparency = 0.5
    
    ElseIf Worksheets("Summary").Range("K18") = "B" Then
    ActiveSheet.Shapes("SHAPE 1").ZOrder msoBringToFront
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 57
    ActiveSheet.Shapes("SHAPE 1").Fill.Solid
    ActiveSheet.Shapes("SHAPE 1").Fill.Transparency = 0.5
    
    ElseIf Worksheets("Summary").Range("K18") = "C" Then
    ActiveSheet.Shapes("SHAPE 1").ZOrder msoBringToFront
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 52
    ActiveSheet.Shapes("SHAPE 1").Fill.Solid
    ActiveSheet.Shapes("SHAPE 1").Fill.Transparency = 0.5
    
    ElseIf Worksheets("Summary").Range("K18") = "D" Then
    ActiveSheet.Shapes("SHAPE 1").ZOrder msoBringToFront
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 10
    ActiveSheet.Shapes("SHAPE 1").Fill.Solid
    ActiveSheet.Shapes("SHAPE 1").Fill.Transparency = 0.5
    
    ElseIf Worksheets("Summary").Range("K18") = "0" Then
    ActiveSheet.Shapes("SHAPE 1").ZOrder msoSendToBack

End If

 

[onlyadrafter]

Hello,

How about

Sub tred()
Select Case Sheets("Summary").Range("K18").Value
    Case "A"
        BASICS
        ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 12
    Case "B"
        BASICS
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 57
    Case "C"
        BASICS
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 52
    Case "D"
        BASICS
    ActiveSheet.Shapes("SHAPE 1").Fill.ForeColor.SchemeColor = 10
    Case "O"
    ActiveSheet.Shapes("SHAPE 1").ZOrder msoSendToBack
End Select
End Sub
Sub BASICS()
     ActiveSheet.Shapes("SHAPE 1").ZOrder msoBringToFront
     ActiveSheet.Shapes("SHAPE 1").Fill.Solid
     ActiveSheet.Shapes("SHAPE 1").Fill.Transparency = 0.5
End Sub

 

[jwchu3]

here is part of your code, untested but should work.

Sub col_shape()

With ActiveSheet.Shapes("SHAPE1")
.ZOrder msoBringToFront
.Fill.ForeColor.SchemeColor = 12
.Fill.Solid
.Fill.Transparency = 0.5
End With

End Sub

 

[jwchu3]

onlyadrafter,

i like your solution. very neat!

 

[Atholl]

Hey guys,

Thanks for the input!

Is there a way to 'genericise' the 'BASICS' sub so that it doesn't have to be repeated another 27 times?

Atholl

 

[Richard Schollar]

Hi Atholl

You could pass the name of the shape (or possibly a reference to the actual object) to the Sub as an argument:

Sub Basics(ShName As String)
....
With ActiveSheet.SHAPES(ShName)
....

Best regards

Richard

 

[Atholl]

Hi Richard,

I was attempting to implement your suggestion to no avail; can you elaborate for a VB dunce?!

Atholl

 

[Richard Schollar]

Hi Atholl

This works for me:

Sub test()
shaName = ActiveSheet.Shapes(1).Name
changer (shaName)
End Sub
Sub changer(shaName As String)
With ActiveSheet.Shapes(shaName)
    .Fill.ForeColor.SchemeColor = 12
    .Fill.Solid
End With
End Sub

or as an Object ref:

Sub test()
Dim shaName As Shape
 Set shaName = ActiveSheet.Shapes(1)
changer shaName
End Sub
Sub changer(shap As Object)
With shap
    .Fill.ForeColor.SchemeColor = 6
    .Fill.Solid
End With
End Sub

Best regards

Richard

 

[Atholl]

Hi Richard,

Great stuff as always!

Thanks,

Atholl