Filling cells partially (based on percentage) and any colour of my choice

[sjoerd.bosch]

Hi All

Looking for a VBA code what allows me to fill cells (14 in total - never mind which ones - as long I can change it to my choice after - to use in different workbooks)
The cells have to be partially filled - based on percentage - like in the spark line method - and with a colour of my choice, to mark different products.
Like a tank what is filled to a certain percentage - with an option to fill with different products - each having a different colour.

I used Sparkline option - which works - but then I have to change the colour manually. Not conditional formatting.
I want to use a code - for example product A = light red, B= light blue, C= light green, D= light yellow, E=dark red, and if more needed - to add any

Appreciated any suggestions

 

[Legacy 143009]

Could you please share a sample data with a visual of desired result?

 

[sjoerd.bosch]

Could you please share a sample data with a visual of desired result?

See attached. It is an example of how should look made with sparklines - except for the fact that I have to change colours for each tank - it is working fine.
So hopefully there is a VBA code what allows me to assign a Letter to each grade and what behaves like the sparklines - concerning changing levels in each tank based on percentage

 

[Legacy 143009]

I didn't get your grading system. Where do you want to assign letters?

How about a different suggestion? Would you like, let say you color B7 cell to light red and the related tank becomes that color? Is this practical for you?

If you don't want this you, can you show an example with assigning letters?

 

[sjoerd.bosch]

I didn't get your grading system. Where do you want to assign letters?

How about a different suggestion? Would you like, let say you color B7 cell to light red and the related tank becomes that color? Is this practical for you?

If you don't want this you, can you show an example with assigning letters?

Yes, that is also fine. As long I can chose a colour what matches contents of the tank.
Or if there is a list elsewhere in the form what assigns a colour to a product

 

[Legacy 143009]

Hi,

This is the solution I came up with. It works with shapes. It will adjust itself according to column widths and row heights. Also it allows where to start tanks and determine tank sizes (spans). Here is an example where tanks start at 8th row of 5th column. They are 4 rows in height and 2 columns wide. The tanks will inherit the font and fill color of the relevant cell.

Sub updateShapes()
  Dim r As Long, c As Long, rowsHeights As Double, columnsWidth As Double, shapeHeight As Long, shapeWidth As Long
  Dim startRow As Long, startCol As Long, s As Long, rowSpan As Long, columnSpan As Long
  rowsHeights = 0
  columnsWidth = 0
  rowSpan = 4 'Select tanks rows height
  columSpan = 2 'select tanks columns width
  startRow = 8 'tanks starting row
  startCol = 5 'tanks starting column
  s = 1
  With ActiveSheet
  For c = 2 To 3
    For r = 8 To 14
      .Shapes(s).Height = ((.Rows(startRow).Offset(-1 * (rowSpan - 1)).Resize(rowSpan).Height * .Cells(r, c).Value) / 100) - .Shapes(s).Line.Weight
      .Shapes(s).Top = .Rows(1).Resize(startRow).Height - (.Shapes(s).Height + (.Shapes(s).Line.Weight / 2))
      .Shapes(s).Width = (.Columns(startCol).Resize(1, columSpan).Width * 0.8) - (.Shapes(s).Line.Weight / 2)
      .Shapes(s).Left = (.Columns(1).Resize(1, startCol - 1).Width + ((.Columns(startCol).Resize(1, columSpan).Width - .Shapes(s).Width) / 2)) + (.Shapes(s).Line.Weight)
      .Shapes(s).TextFrame.Characters.Text = .Cells(r, c).Value & "%"
      .Shapes(s).TextFrame.HorizontalAlignment = xlCenter
      .Shapes(s).TextFrame.VerticalAlignment = xlCenter
      .Shapes(s).Fill.ForeColor.RGB = .Cells(r, c).Interior.Color
      .Shapes(s).TextFrame.Characters.Font.Color = .Cells(r, c).Font.Color
      startRow = startRow + rowSpan
      s = s + 1
    Next
    startRow = 8
    startCol = startCol + columSpan
  Next
  End With
End Sub

Here I am leaving a sample book for you to play around with.

WeTransfer | Send Large Files Fast - Up To 2GB Free

The simple, quick and secure way to send your files around the world without an account. Share your files, photos, and videos today for free.

we.tl

 

[sjoerd.bosch]

Hi,
View attachment 102204
This is the solution I came up with. It works with shapes. It will adjust itself according to column widths and row heights. Also it allows where to start tanks and determine tank sizes (spans). Here is an example where tanks start at 8th row of 5th column. They are 4 rows in height and 2 columns wide. The tanks will inherit the font and fill color of the relevant cell.

Sub updateShapes()
  Dim r As Long, c As Long, rowsHeights As Double, columnsWidth As Double, shapeHeight As Long, shapeWidth As Long
  Dim startRow As Long, startCol As Long, s As Long, rowSpan As Long, columnSpan As Long
  rowsHeights = 0
  columnsWidth = 0
  rowSpan = 4 'Select tanks rows height
  columSpan = 2 'select tanks columns width
  startRow = 8 'tanks starting row
  startCol = 5 'tanks starting column
  s = 1
  With ActiveSheet
  For c = 2 To 3
    For r = 8 To 14
      .Shapes(s).Height = ((.Rows(startRow).Offset(-1 * (rowSpan - 1)).Resize(rowSpan).Height * .Cells(r, c).Value) / 100) - .Shapes(s).Line.Weight
      .Shapes(s).Top = .Rows(1).Resize(startRow).Height - (.Shapes(s).Height + (.Shapes(s).Line.Weight / 2))
      .Shapes(s).Width = (.Columns(startCol).Resize(1, columSpan).Width * 0.8) - (.Shapes(s).Line.Weight / 2)
      .Shapes(s).Left = (.Columns(1).Resize(1, startCol - 1).Width + ((.Columns(startCol).Resize(1, columSpan).Width - .Shapes(s).Width) / 2)) + (.Shapes(s).Line.Weight)
      .Shapes(s).TextFrame.Characters.Text = .Cells(r, c).Value & "%"
      .Shapes(s).TextFrame.HorizontalAlignment = xlCenter
      .Shapes(s).TextFrame.VerticalAlignment = xlCenter
      .Shapes(s).Fill.ForeColor.RGB = .Cells(r, c).Interior.Color
      .Shapes(s).TextFrame.Characters.Font.Color = .Cells(r, c).Font.Color
      startRow = startRow + rowSpan
      s = s + 1
    Next
    startRow = 8
    startCol = startCol + columSpan
  Next
  End With
End Sub

Here I am leaving a sample book for you to play around with.

WeTransfer | Send Large Files Fast - Up To 2GB Free

The simple, quick and secure way to send your files around the world without an account. Share your files, photos, and videos today for free.

we.tl

great stuff. Thanks!

 

[Peter_SSs]

great stuff. Thanks!

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.