How to fill X number of cells based on value

J

jajukhan

New Member
Joined
Nov 22, 2018
Messages
6
Hello,
I have a list of values in Column A.
Based on the number stated I would like to colour fill that number of cells.
So if A1=4 then fill B1, C1, D1 and E1 with a colour.

There is another complexity, which is that some of the values have decimal places.

So if B1=3.5 then fill B2,C2,D2 and half of E2

Final complexity, I also need to use multiple colours based on values in each Column.
So values given in Column A will fill cells with Blue colour. Then values given in Column B will fill cells in Yellow colour.
 

Attachments

  • A141EAD4-BC2C-4BA2-83F1-0622F93229C9.png
    A141EAD4-BC2C-4BA2-83F1-0622F93229C9.png
    126.2 KB · Views: 18

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Is it possible that you could have decimals in both columns?

I've been trying to find a solution that will work on that scenario, but it doesn't appear possible. Also, looking at your screen capture, it appears that you are using a mobile version of excel. This will limit the options that you have available to you so it might not be possible on that platform without decimals in both columns.
 
Upvote 0
jasonb75 said:
Is it possible that you could have decimals in both columns?

I've been trying to find a solution that will work on that scenario, but it doesn't appear possible. Also, looking at your screen capture, it appears that you are using a mobile version of excel. This will limit the options that you have available to you so it might not be possible on that platform without decimals in both columns.
Click to expand...
Hi Jasonb75
I only used the web version for the screenshot. I'll be using the full Windows Excel version.

There is a possibility of having decimal in both. But I could manage it by keeping one of the columns as an Integer value.
 
Upvote 0
With the full windows version, you could overcome the hurdles with vba, I had previously dismissed that as an option because of the limitations on mobile versions of excel.

Can I assume that the numbers in A2 and B2 are typed in rather than being formula results?
 
Upvote 0
I think that I've allowed for most things that can go wrong in the code below. Note that the code works as data is entered, it will not apply the colour scheme to existing entries.

As per the screen capture it is set specifically for entries in columns A and B. Other than headers in row 1, no allowance has been made for anything else being entered into the sheet. Anything entered to the right of column B will be ignored, however, entering or changing the values in columns A or B will cause anything to the right to be deleted.

To reduce errors in the output, the code will not allow you to enter a value in column B if column A is empty. If the value in column A is changed after column B has been entered then the value in column B and the associated coloured cells will be cleared.

The code below needs to go into the correct worksheet module (right click on the sheet tab in excel, then click 'view code' and paste the copied code into the module that opens).

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Dim fCol As Long, lCol As Long, tVal As Double, c As Range, tcol As Long
For Each c In Target
    Select Case c.Column
        Case 1
            fCol = 3
            lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
            With Range(Cells(c.Row, 2), Cells(c.Row, IIf(lCol < 3, 3, lCol)))
                .ClearContents
                .EntireRow.FormatConditions.Delete
            End With
            If c.Value <> "" Then
                tVal = c.Value
         
                Do
                    Cells(c.Row, fCol).Value = IIf(tVal < 1, tVal, 1)
                    tVal = tVal - 1
                    If tVal <= 0 Then Exit Do
                    fCol = fCol + 1
                Loop
                With Range(Cells(c.Row, 3), Cells(c.Row, fCol))
                    .FormatConditions.AddDatabar
                    With .FormatConditions(1)
                        .ShowValue = False
                        .BarColor.Color = 12611584
                        .BarFillType = xlDataBarFillSolid
                        .MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
                        .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
                    End With
                End With
            End If
        Case 2
            If c.Offset(, -1).Value = "" And c.Value <> "" Then
                MsgBox "Error, Write up time must be entered first", vbCritical
                c.ClearContents
            Else
                fCol = Application.WorksheetFunction.RoundUp(Cells(c.Row, 1).Value + 3, 0)
                lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column

                With Range(Cells(c.Row, fCol), Cells(c.Row, IIf(lCol < fCol, fCol, lCol)))
                    .ClearContents
                    .FormatConditions.Delete
                End With
            End If
                tVal = c.Value
                tcol = fCol
            If c.Value <> "" Then
                Do
                    Cells(c.Row, fCol).Value = IIf(tVal < 1, tVal, 1)
                    tVal = tVal - 1
                    If tVal <= 0 Then Exit Do
                    fCol = fCol + 1
                Loop
                With Range(Cells(c.Row, tcol), Cells(c.Row, fCol))
                    .FormatConditions.AddDatabar
                    With .FormatConditions(1)
                        .ShowValue = False
                        .BarColor.Color = 65535
                        .BarFillType = xlDataBarFillSolid
                        .MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
                        .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
                    End With
                End With
            End If
    End Select
Next c
    Application.EnableEvents = True
End Sub

Hope this helps.

edit:- table showing output removed as it didn't actually show the colour applied to the cells.

@smozgur is this a known issue with conditional formatting and XL2BB? The mini sheet that I attempted to post contains data bars, no formatting was visible when it was submitted.
 
Last edited:
Upvote 0
Solution
jasonb75 said:
I think that I've allowed for most things that can go wrong in the code below. Note that the code works as data is entered, it will not apply the colour scheme to existing entries.

As per the screen capture it is set specifically for entries in columns A and B. Other than headers in row 1, no allowance has been made for anything else being entered into the sheet. Anything entered to the right of column B will be ignored, however, entering or changing the values in columns A or B will cause anything to the right to be deleted.

To reduce errors in the output, the code will not allow you to enter a value in column B if column A is empty. If the value in column A is changed after column B has been entered then the value in column B and the associated coloured cells will be cleared.

The code below needs to go into the correct worksheet module (right click on the sheet tab in excel, then click 'view code' and paste the copied code into the module that opens).

VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Dim fCol As Long, lCol As Long, tVal As Double, c As Range, tcol As Long
For Each c In Target
    Select Case c.Column
        Case 1
            fCol = 3
            lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
            With Range(Cells(c.Row, 2), Cells(c.Row, IIf(lCol < 3, 3, lCol)))
                .ClearContents
                .EntireRow.FormatConditions.Delete
            End With
            If c.Value <> "" Then
                tVal = c.Value
        
                Do
                    Cells(c.Row, fCol).Value = IIf(tVal < 1, tVal, 1)
                    tVal = tVal - 1
                    If tVal <= 0 Then Exit Do
                    fCol = fCol + 1
                Loop
                With Range(Cells(c.Row, 3), Cells(c.Row, fCol))
                    .FormatConditions.AddDatabar
                    With .FormatConditions(1)
                        .ShowValue = False
                        .BarColor.Color = 12611584
                        .BarFillType = xlDataBarFillSolid
                        .MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
                        .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
                    End With
                End With
            End If
        Case 2
            If c.Offset(, -1).Value = "" And c.Value <> "" Then
                MsgBox "Error, Write up time must be entered first", vbCritical
                c.ClearContents
            Else
                fCol = Application.WorksheetFunction.RoundUp(Cells(c.Row, 1).Value + 3, 0)
                lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column

                With Range(Cells(c.Row, fCol), Cells(c.Row, IIf(lCol < fCol, fCol, lCol)))
                    .ClearContents
                    .FormatConditions.Delete
                End With
            End If
                tVal = c.Value
                tcol = fCol
            If c.Value <> "" Then
                Do
                    Cells(c.Row, fCol).Value = IIf(tVal < 1, tVal, 1)
                    tVal = tVal - 1
                    If tVal <= 0 Then Exit Do
                    fCol = fCol + 1
                Loop
                With Range(Cells(c.Row, tcol), Cells(c.Row, fCol))
                    .FormatConditions.AddDatabar
                    With .FormatConditions(1)
                        .ShowValue = False
                        .BarColor.Color = 65535
                        .BarFillType = xlDataBarFillSolid
                        .MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
                        .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
                    End With
                End With
            End If
    End Select
Next c
    Application.EnableEvents = True
End Sub

Hope this helps.

edit:- table showing output removed as it didn't actually show the colour applied to the cells.

@smozgur is this a known issue with conditional formatting and XL2BB? The mini sheet that I attempted to post contains data bars, no formatting was visible when it was submitted.
Click to expand...

Thanks Jasonb75 for all your help and support. I really appreciate it.
However, I'm unable to get the script working. I've saved the script as instructed in the correct sheet and also saved the file as XLSM.

1662241294688.png
 
Upvote 0
In the code editor press Ctrl g and you will get a small window appear at the bottom of the module, with the heading 'Immediate'

Copy the line of code below and paste it into that small window, then press enter (make sure that the cursor is at the end of the line of code before you press enter, if it has already dropped below then the command will not work).
VBA Code: 
Application.EnableEvents = True

Then go back to excel and try entering values into columns A and B again.

If that doesn't work, try saving everything that you need to and completely close excel (everything that is open, not just that workbook) then open it again and look out for any prompts to allow the code to run.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
How to return a value if a cell/ row coloured cell
Replies
1
Views
206
etaf
etaf
A
  • Solved
Conditional Formatting - apply rules to multiple rows based on specific cells (drop down menus)
Replies
4
Views
746
AndyB86
A
L
  • Solved
Formatting cells filled by array formulae
Replies
5
Views
216
Ludwig
L
S
  • Solved
Filling cells partially (based on percentage) and any colour of my choice
Replies
7
Views
924
Peter_SSs
Peter_SSs
T
  • Solved
VBA to Move cell pointer within range
2
Replies
18
Views
312
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,750
Messages
6,180,740
Members
452,996
Latest member
nelsonsix66

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