Simplifying Conditional Formatting

A

AJLS

New Member
Joined
Sep 14, 2023
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have been working an sheet where the my key feature is the visual created by cell colour and border, the purpose is producing images of engineered components (not to scale) by entering the values required. With the cell columns formatting based on a cell value in G2. I have done the conditional formatting of the cells by coping, pasting and editing the formula in increments of 2.5 (time consuming). Is there an easier way using VBA? I will be looking to increase the capacity of the sheet rows that are formatted by G2, currently 100, meaning further formatting. There are several sections with the same formatting (10 currently, I may need more) so if I can ease the burden with VBA it would be ideal.

I have highlighted Cell G2 and the cell range in yellow

Thank you
 

Attachments

  • Conditional Formatting.png
    Conditional Formatting.png
    23.5 KB · Views: 12
  • Sheet sample.png
    Sheet sample.png
    15.9 KB · Views: 13

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Hi AJLS,

It looks as though you are using the formatting to add an image of a rectangle to the screen as a visual.

If so you could use VBA to manipulate a shapes based on the size and measurments etc populated on your sheet.

If you add the below shapes to a sheet and run the code it will size and scale the shape based on the dimensions given...
  • "Rectangle A 1" - Shaded rectangle
  • "Rectangle B 1" - Yellow Rectangle
  • "Straight Arrow Connector 1"
  • "Straight Connector A 1"
  • "Straight Connector B 1"
  • "Straight Connector C 1"
  • "TextBox 1"
Names above are what is in my code, alternatively you can change the names in the code to what you have on your sheet.

This code can be scaled up whereby it adds in the shapes to a blank sheet, and runs through on a loop to add in more shapes if required.

VBA Code: 
Sub ScaleShape()

Dim ShapeScale As Single
Dim Diam As Single
Dim Length As Single
Dim Pixel As Single
Dim LeftVal As Single
Dim TopVal As Single

'Below sets the top left starting point for all of the shapes to build out from...
LeftVal = 288
TopVal = 225

Pixel = 2.834646 'Height of 1mm on my screen
ShapeScale = Sheet1.Range("G10").Value
Diam = Sheet1.Range("G2").Value * Pixel * ShapeScale
Length = Sheet1.Range("G4").Value * Pixel * ShapeScale

With ActiveSheet.Shapes.Range(Array("Rectangle A 1"))
    .Left = LeftVal
    .Top = TopVal + 75
    .Height = Diam
    .Width = Length
End With

With ActiveSheet.Shapes.Range(Array("Rectangle B 1"))
    .Left = LeftVal - 75
    .Top = TopVal + 75
    .Height = Diam
End With

With ActiveSheet.Shapes.Range(Array("Straight Arrow Connector 1"))
    .Top = TopVal
    .Left = LeftVal
    .Width = Length
End With

With ActiveSheet.Shapes.Range(Array("Straight Connector A 1"))
    .Top = TopVal
    .Left = LeftVal
End With

With ActiveSheet.Shapes.Range(Array("Straight Connector B 1"))
    .Top = TopVal
    .Left = LeftVal + Length
End With

With ActiveSheet.Shapes.Range(Array("Straight Connector C 1"))
    .Left = LeftVal - 30
    .Width = Length + 50
    .Top = Diam / 2 + TopVal + 75
End With

With ActiveSheet.Shapes.Range(Array("TextBox 1"))
    .TextFrame2.TextRange.Characters.Text = Sheet1.Range("G4").Value
    .Top = TopVal - (.Height / 2)
    .Left = (Length / 2) + LeftVal - (.Width / 2)
    .Width = Len(Sheet1.Range("G4").Value) * 15
End With
  
End Sub

My Result....

ScaleShape.jpg
 
Upvote 0
Hi sxhall,

Thanks for replying. I should have shared a little more detail, the rectangles representing the diameter will be different in several sections of the sheet so if I used the above all cells in the row would be formatted, so I have had to use individual cells. I have added some (lengthy) code to alter the width based on the length value so this will be helpful to trim that code down. I have 10 sections currently that would usually be various dimensions.
 

Attachments

  • Example 2.png
    Example 2.png
    13.5 KB · Views: 5
Upvote 0
Hi,

Had a play about with what I submitted previously and if you run the below it will work for dfferent dimensions on section and for as many sections as you require.

To do this I have structured the data slightly differently so it goes across in rows and have added in a number of sections field to determine how many loops (/sections) the code will run for.

There is no need to any add shapes to the sheet now either it will run from a blank sheet so long as there is data in the cells as I have shown in the image. Running the code again will delete all the shapes not required and then start again from fresh.


VBA Code: 
Sub ScaleShape()

Dim Sections As Integer
Dim ShapeScale As Single
Dim Diam As Single
Dim Length As Single
Dim OvrLength As Single
Dim Pixel As Single
Dim LeftVal As Single
Dim TopVal As Single
Dim Centre As Single
Dim TopBar As Single
Dim InfoText As String

With Application
    .ScreenUpdating = False
End With

LeftVal = 288
TopVal = 300
OvrLength = LeftVal
Pixel = 2.834646 'Height of 1mm on my screen

ShapeScale = Sheet1.Range("D2").Value
Sections = Sheet1.Range("D4").Value
Diam = Sheet1.Range("F2").Offset(0, 1).Value * Pixel * ShapeScale
Length = Sheet1.Range("F3").Offset(0, 1).Value * Pixel * ShapeScale
Centre = (WorksheetFunction.Max(Range("F2").Resize(1, Sections)) * Pixel / 2) + TopVal

With ActiveSheet

'Delete all shapes that start with "Del"
For Each Shape In .Shapes
     If Shape.Name Like "Del*" Then
     Shape.Delete
     End If
Next Shape

'Add Yellow Rectangle, only once...
For Each Shape In .Shapes
     If Shape.Name = "Rectangle Yellow" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1).Name = "Rectangle Yellow"
End If

With ActiveSheet.Shapes.Range(Array("Rectangle Yellow"))
    .Left = OvrLength - 75
    .Top = TopVal
    .Height = (WorksheetFunction.Max(Range("F2").Resize(1, Sections)) * Pixel)
    .Width = 40
    .Line.Visible = msoFalse
    .Fill.ForeColor.RGB = RGB(255, 255, 0)
End With

'Add Left Bar only once....
For Each Shape In .Shapes
     If Shape.Name = "ConnectorL" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "ConnectorL"
End If

With ActiveSheet.Shapes.Range(Array("ConnectorL"))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Height = 80
        .Top = TopVal - 100
        .Left = OvrLength
End With

'Loop through add and move shapes based on number of sections...
Dim i

For i = 1 To Sections
Sheet1.Range("F2").Offset(0, i).Select
Diam = Sheet1.Range("F2").Offset(0, i).Value * Pixel * ShapeScale
Length = Sheet1.Range("F3").Offset(0, i).Value * Pixel * ShapeScale

    .Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1).Name = "Del Rect Sect " & i
    With ActiveSheet.Shapes.Range(Array("Del Rect Sect " & i))
        .Left = OvrLength
        .Top = Centre - (Diam / 2)
        .Height = Diam
        .Width = Length
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .Fill.BackColor.ObjectThemeColor = msoThemeColorBackground1
        .Fill.Patterned msoPattern5Percent
        .Fill.Patterned msoPatternDarkUpwardDiagonal
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
    End With

    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Del Arrows Sect" & i
    With ActiveSheet.Shapes.Range(Array("Del Arrows Sect" & i))
        .Line.BeginArrowheadStyle = msoArrowheadTriangle
        .Line.EndArrowheadStyle = msoArrowheadTriangle
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Top = TopVal - 100
        .Left = OvrLength
        .Width = Length
    End With

    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Del ConnectorR Sect " & i
    With ActiveSheet.Shapes.Range(Array("Del ConnectorR Sect " & i))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Height = 80
        .Top = TopVal - 100
        .Left = OvrLength + Length
    End With
    
    .Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1, 1).Name = "Del TextBox Sect Len" & i
    With ActiveSheet.Shapes.Range(Array("Del TextBox Sect Len" & i))
        .Width = Len(Sheet1.Range("F3").Offset(0, i).Value) * 15
        .Height = 30
        .Top = TopVal - 100 - (.Height / 2)
        .Left = (Length / 2) + OvrLength - (.Width / 2)
        .Line.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = Sheet1.Range("F3").Offset(0, i).Value
            .TextRange.Font.Size = 14
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .VerticalAnchor = msoAnchorMiddle
        End With
    End With
    
    InfoText = "Ø" & Sheet1.Range("F2").Offset(0, i).Value & "mm" & vbCrLf & "+/-" & Sheet1.Range("F5").Offset(0, i).Value
    .Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1, 1).Name = "Del TextBox Sect Dia" & i
    With ActiveSheet.Shapes.Range(Array("Del TextBox Sect Dia" & i))
        .Width = Length 'Len(Sheet1.Range("F2").Offset(0, i).Value) * 15
        .Height = 50
        .Top = TopVal - 60 - (.Height / 2)
        .Left = (Length / 2) + OvrLength - (.Width / 2)
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = InfoText
            .TextRange.Font.Size = 10
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .VerticalAnchor = msoAnchorMiddle
        End With
    End With
OvrLength = OvrLength + Length
Next i
'End of Loop
    
'Add Centreline, only once...
For Each Shape In .Shapes
     If Shape.Name = "Connector Centre" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Connector Centre"
End If
    With ActiveSheet.Shapes.Range(Array("Connector Centre"))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Left = LeftVal - 30
        .Width = OvrLength - 220
        .Top = Centre
        .ZOrder msoBringToFront
    End With
End With

With Application
    .ScreenUpdating = True
End With

End Sub

This is what I get with 13 sections. I can expand the table to the right and just adjust the number of sections up or down to create more or less sections as required.

ScaleShape2.jpg
 
Upvote 0
Solution
sxhall said:
Hi,

Had a play about with what I submitted previously and if you run the below it will work for dfferent dimensions on section and for as many sections as you require.

To do this I have structured the data slightly differently so it goes across in rows and have added in a number of sections field to determine how many loops (/sections) the code will run for.

There is no need to any add shapes to the sheet now either it will run from a blank sheet so long as there is data in the cells as I have shown in the image. Running the code again will delete all the shapes not required and then start again from fresh.


VBA Code: 
Sub ScaleShape()

Dim Sections As Integer
Dim ShapeScale As Single
Dim Diam As Single
Dim Length As Single
Dim OvrLength As Single
Dim Pixel As Single
Dim LeftVal As Single
Dim TopVal As Single
Dim Centre As Single
Dim TopBar As Single
Dim InfoText As String

With Application
    .ScreenUpdating = False
End With

LeftVal = 288
TopVal = 300
OvrLength = LeftVal
Pixel = 2.834646 'Height of 1mm on my screen

ShapeScale = Sheet1.Range("D2").Value
Sections = Sheet1.Range("D4").Value
Diam = Sheet1.Range("F2").Offset(0, 1).Value * Pixel * ShapeScale
Length = Sheet1.Range("F3").Offset(0, 1).Value * Pixel * ShapeScale
Centre = (WorksheetFunction.Max(Range("F2").Resize(1, Sections)) * Pixel / 2) + TopVal

With ActiveSheet

'Delete all shapes that start with "Del"
For Each Shape In .Shapes
     If Shape.Name Like "Del*" Then
     Shape.Delete
     End If
Next Shape

'Add Yellow Rectangle, only once...
For Each Shape In .Shapes
     If Shape.Name = "Rectangle Yellow" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1).Name = "Rectangle Yellow"
End If

With ActiveSheet.Shapes.Range(Array("Rectangle Yellow"))
    .Left = OvrLength - 75
    .Top = TopVal
    .Height = (WorksheetFunction.Max(Range("F2").Resize(1, Sections)) * Pixel)
    .Width = 40
    .Line.Visible = msoFalse
    .Fill.ForeColor.RGB = RGB(255, 255, 0)
End With

'Add Left Bar only once....
For Each Shape In .Shapes
     If Shape.Name = "ConnectorL" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "ConnectorL"
End If

With ActiveSheet.Shapes.Range(Array("ConnectorL"))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Height = 80
        .Top = TopVal - 100
        .Left = OvrLength
End With

'Loop through add and move shapes based on number of sections...
Dim i

For i = 1 To Sections
Sheet1.Range("F2").Offset(0, i).Select
Diam = Sheet1.Range("F2").Offset(0, i).Value * Pixel * ShapeScale
Length = Sheet1.Range("F3").Offset(0, i).Value * Pixel * ShapeScale

    .Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1).Name = "Del Rect Sect " & i
    With ActiveSheet.Shapes.Range(Array("Del Rect Sect " & i))
        .Left = OvrLength
        .Top = Centre - (Diam / 2)
        .Height = Diam
        .Width = Length
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .Fill.BackColor.ObjectThemeColor = msoThemeColorBackground1
        .Fill.Patterned msoPattern5Percent
        .Fill.Patterned msoPatternDarkUpwardDiagonal
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
    End With

    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Del Arrows Sect" & i
    With ActiveSheet.Shapes.Range(Array("Del Arrows Sect" & i))
        .Line.BeginArrowheadStyle = msoArrowheadTriangle
        .Line.EndArrowheadStyle = msoArrowheadTriangle
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Top = TopVal - 100
        .Left = OvrLength
        .Width = Length
    End With

    .Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Del ConnectorR Sect " & i
    With ActiveSheet.Shapes.Range(Array("Del ConnectorR Sect " & i))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Height = 80
        .Top = TopVal - 100
        .Left = OvrLength + Length
    End With
   
    .Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1, 1).Name = "Del TextBox Sect Len" & i
    With ActiveSheet.Shapes.Range(Array("Del TextBox Sect Len" & i))
        .Width = Len(Sheet1.Range("F3").Offset(0, i).Value) * 15
        .Height = 30
        .Top = TopVal - 100 - (.Height / 2)
        .Left = (Length / 2) + OvrLength - (.Width / 2)
        .Line.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = Sheet1.Range("F3").Offset(0, i).Value
            .TextRange.Font.Size = 14
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .VerticalAnchor = msoAnchorMiddle
        End With
    End With
   
    InfoText = "Ø" & Sheet1.Range("F2").Offset(0, i).Value & "mm" & vbCrLf & "+/-" & Sheet1.Range("F5").Offset(0, i).Value
    .Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, 1, 1).Name = "Del TextBox Sect Dia" & i
    With ActiveSheet.Shapes.Range(Array("Del TextBox Sect Dia" & i))
        .Width = Length 'Len(Sheet1.Range("F2").Offset(0, i).Value) * 15
        .Height = 50
        .Top = TopVal - 60 - (.Height / 2)
        .Left = (Length / 2) + OvrLength - (.Width / 2)
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        With .TextFrame2
            .TextRange.Characters.Text = InfoText
            .TextRange.Font.Size = 10
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .VerticalAnchor = msoAnchorMiddle
        End With
    End With
OvrLength = OvrLength + Length
Next i
'End of Loop
   
'Add Centreline, only once...
For Each Shape In .Shapes
     If Shape.Name = "Connector Centre" Then Flag = 1
Next Shape

If Flag > 0 Then
Else
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1).Name = "Connector Centre"
End If
    With ActiveSheet.Shapes.Range(Array("Connector Centre"))
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Left = LeftVal - 30
        .Width = OvrLength - 220
        .Top = Centre
        .ZOrder msoBringToFront
    End With
End With

With Application
    .ScreenUpdating = True
End With

End Sub

This is what I get with 13 sections. I can expand the table to the right and just adjust the number of sections up or down to create more or less sections as required.

View attachment 98728
Click to expand...
I don't know whether to laugh or cry, I spent hours formatting those cells. it applies a border also, I have another thread looking for an easier way to do that. I'll get it in the sheet and close this one out.
Thank you you so much.
 
Upvote 0
There is no "closing a thread" action on the board. Either there is an answer that solved the problem or not. If you would like to post your own solution or another link that answers this question then it is perfectly fine to mark your post as the solution to help future readers. Otherwise, please do not mark a post that doesn't contain a solution.
 
Upvote 0
AJLS said:
I don't know whether to laugh or cry, I spent hours formatting those cells. it applies a border also, I have another thread looking for an easier way to do that. I'll get it in the sheet and close this one out.
Thank you you so much.
Click to expand...
Hi sxhall,

I was hoping not to bother you again, I have tried to plug and play. My sheet is set out as below, I am receiving Run time error 424 (Object required) and 1004 (Application-defined or object-defined error). there is an issue referencing D2, D4, F2, and F3. In your table, is the number of sections in the table dictated by the value in D4?

I am working though to try and understand the programming, it is all new to me. Do you have any data in columns A, B, or C?

Thank you
 

Attachments

  • Sheet Set Up.png
    Sheet Set Up.png
    17.2 KB · Views: 1
Upvote 0
AJLS said:
Hi sxhall,

I was hoping not to bother you again, I have tried to plug and play. My sheet is set out as below, I am receiving Run time error 424 (Object required) and 1004 (Application-defined or object-defined error). there is an issue referencing D2, D4, F2, and F3. In your table, is the number of sections in the table dictated by the value in D4?

I am working though to try and understand the programming, it is all new to me. Do you have any data in columns A, B, or C?

Thank you
Click to expand...
Hi,

Just an update, the sheet is working great, i will be making a few tweaks to finalise but the above solution works great.

Thank you
 
Upvote 0
Hi sxhall,

Sheet is working great, is it possible to amend the code so table columns to match the width of the relative sections?

Thanks you
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
VBA Conditional Formatting
Replies
4
Views
309
dreid1011
dreid1011
B
  • Question
Conditional Formatting for multiple cells based on other cell value
Replies
4
Views
299
Benong
B
B
  • Solved
Count Coloured cells
2
Replies
10
Views
406
baileyb103
B
T
  • Question
VBA Formatting Rows
Replies
7
Views
224
dreid1011
dreid1011
P
  • Question
Applying conditional formatting to merged cells
Replies
1
Views
317
Joe4
Joe4

Forum statistics

Threads
1,215,102
Messages
6,123,097
Members
449,096
Latest member
provoking

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top