VBA to Color Each Cell in a Range to show OnDuty and other color to show OffDuty

CubaRJ

CubaRJ

New Member
Joined
Mar 21, 2022
Messages
29
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi!

I need help to build a loop that will paint a row in a color to show on duty dates and another loop to paint the off duty.

The idea is to have a button to fire up the color based on user´s settings for OnDuty, OffDuty and Rotations, I have set a minishet for better understanding.

Starting point will always be the Acive Cell the user click, OnDuty will be the numbe rof days a person workm OffDuty the number of days a person rests, rotations will be sum of a full work session plus rest (OnDuty+OffDuty).
If the user click on E5 with setting OnDuty 14, OffDuty 21 and Rotation 9 it would paint the cells as per the example below

  1. If the user click on E7 with setting OnDuty 14, OffDuty 14 and Rotation 9 it would paint the cells as per the example below
  2. If the user click on E9 with setting OnDuty 21, OffDuty 21 and Rotation 9 it would paint the cells as per the example below
  3. If the user click on E11 with setting OnDuty 28, OffDuty 28 and Rotation 9 it would paint the cells as per the example below
PS: formatting is not necessary, just need to understand how I would loop using this rule.

Appreciate all the help I can get!

Rotation 14x21.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBDBEBFBGBHBIBJBKBLBMBNBOBPBQBRBSBTBUBVBWBXBYBZCACBCCCDCECFCGCHCICJCKCLCMCNCOCPCQCRCSCTCUCVCWCXCYCZDADBDCDDDEDFDGDHDIDJDKDLDMDNDODPDQDRDSDTDUDVDWDXDYDZEAEBECEDEEEFEGEHEIEJEKELEMENEO
1123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899##########################################################################################################################################
2OnDutyOffDutyRotations
314212SUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUNMONTUEWEDTHUFRISATSUN
401/05/2202/05/2203/05/2204/05/2205/05/2206/05/2207/05/2208/05/2209/05/2210/05/2211/05/2212/05/2213/05/2214/05/2215/05/2216/05/2217/05/2218/05/2219/05/2220/05/2221/05/2222/05/2223/05/2224/05/2225/05/2226/05/2227/05/2228/05/2229/05/2230/05/2231/05/2201/06/2202/06/2203/06/2204/06/2205/06/2206/06/2207/06/2208/06/2209/06/2210/06/2211/06/2212/06/2213/06/2214/06/2215/06/2216/06/2217/06/2218/06/2219/06/2220/06/2221/06/2222/06/2223/06/2224/06/2225/06/2226/06/2227/06/2228/06/2229/06/2230/06/2201/07/2202/07/2203/07/2204/07/2205/07/2206/07/2207/07/2208/07/2209/07/2210/07/2211/07/2212/07/2213/07/2214/07/2215/07/2216/07/2217/07/2218/07/2219/07/2220/07/2221/07/2222/07/2223/07/2224/07/2225/07/2226/07/2227/07/2228/07/2229/07/2230/07/2231/07/2201/08/2202/08/2203/08/2204/08/2205/08/2206/08/2207/08/2208/08/2209/08/2210/08/2211/08/2212/08/2213/08/2214/08/2215/08/2216/08/2217/08/2218/08/2219/08/2220/08/2221/08/2222/08/2223/08/2224/08/2225/08/2226/08/2227/08/2228/08/2229/08/2230/08/2231/08/2201/09/2202/09/2203/09/2204/09/2205/09/2206/09/2207/09/2208/09/2209/09/2210/09/2211/09/2212/09/2213/09/2214/09/2215/09/2216/09/2217/09/2218/09/22
514219EoooooooooooooDhhhhhhhhhhhhhhhhhhhhhEoooooooooooooDhhhhhhhhhhhhhhhhhhhhhEoooooooooooooDhhhhhhhhhhhhhhhhhhhhhEoooooooooooooDhhhhhhhhhhhhhhhhhh
6
714149EoooooooooooooDhhhhhhhhhhhhhEoooooooooooooEoooooooooooooDhhhhhhhhhhhhhEoooooooooooooEoooooooooooooDhhhhhhhhhhhhhEoooooooooooooEoooooooooooooD
8
921219EooooooooooooooooooooDhhhhhhhhhhhhhhhhhhhhEooooooooooooooooooooDhhhhhhhhhhhhhhhhhhhhEooooooooooooooooooooDhhhhhhhhhhhhhhhhhhhhEoooooooooooooo
10
1128289EoooooooooooooooooooooooooooDhhhhhhhhhhhhhhhhhhhhhhhhhhhEoooooooooooooooooooooooooooDhhhhhhhhhhhhhhhhhhhhhhhhhhhEoooooooooooooooooooooooooooD
Planilha1
Cell Formulas
RangeFormula
E3:EO3E3=CHOOSE(WEEKDAY(E4,1),"SUN","MON","TUE","WED","THU","FRI","SAT",)
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
See if you can get this to work in your project. They are just a couple of nested loops.
VBA Code: 
Option Explicit
Sub PatternFilling()
    Dim x      As Long
    Dim y      As Long
    Dim z      As Long
    Dim OnDuty As Long
    Dim OffDuty As Long
    Dim Rotations As Long
    Dim ActiveRow  As Long
    Dim ActiveCol As Long
    Application.ScreenUpdating = False
    ActiveRow = ActiveCell.Row
    ActiveCol = ActiveCell.Column
    OnDuty = Cells(ActiveRow, "B").Value
    OffDuty = Cells(ActiveRow, "C").Value
    Rotations = Cells(ActiveRow, "D").Value
    For x = 1 To Rotations
        Cells(ActiveRow, ActiveCol) = "E"
        'add formatting here
        ActiveCol = ActiveCol + 1
        For y = 1 To OnDuty - 1
            Cells(ActiveRow, ActiveCol) = "o"
            'add formatting here
            ActiveCol = ActiveCol + 1
        Next y
        Cells(ActiveRow, ActiveCol) = "D"
        'add formatting here
        ActiveCol = ActiveCol + 1
        For z = 1 To OffDuty - 1
            Cells(ActiveRow, ActiveCol) = "h"
            'add formatting here
            ActiveCol = ActiveCol + 1
        Next z
    Next x
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
This is some quick and dirty code since I think it is not well written but tested okay ?

You need to put it under the worksheet Planilha1 (not in normal module). It is a macro triggered by Change event.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Dim m As Long, n As Long
Dim eRow As Long
Dim rngData As Range

eRow = Cells(Rows.Count, "B").End(xlUp).Row
Set rngData = Range("B5", "C" & eRow)

If Not Intersect(rngData, Target) Is Nothing Then
    If Target.Offset(-1).Value = 0 Then
        m = 4
        While Not m > 145
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            For n = 1 To Range("B" & Target.Row)
                m = m + 1
                If m > 145 Then
                    Application.EnableEvents = True
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
                Select Case n
                    Case 1
                        With Cells(Target.Row, m)
                            .Value = "E"
                            .Font.Bold = True
                            .Font.Color = 65535
                            .Interior.Color = 6968388
                        End With
                    Case Else
                        With Cells(Target.Row, m)
                            .Value = "o"
                            .Font.Bold = False
                            .Font.Color = 0
                            .Interior.Color = 13224393
                        End With
                End Select
            Next
            For n = 1 To Range("C" & Target.Row)
                m = m + 1
                If m > 145 Then
                    Application.EnableEvents = True
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
                Select Case n
                    Case 1
                        With Cells(Target.Row, m)
                            .Value = "D"
                            .Font.Bold = True
                            .Font.Color = 65535
                            .Interior.Color = 6968388
                        End With
                    Case Else
                        With Cells(Target.Row, m)
                            .Value = "h"
                            .Font.Bold = False
                            .Font.Color = 0
                            .Interior.Color = 13431551
                        End With
                End Select
            Next
        Wend
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End If

End Sub
 
Upvote 0
rollis13 said:
See if you can get this to work in your project. They are just a couple of nested loops.
VBA Code: 
Option Explicit
(...)
    OnDuty = Cells(ActiveRow, "B").Value
    OffDuty = Cells(ActiveRow, "C").Value
    Rotations = Cells(ActiveRow, "D").Value
    (...)
Click to expand...
Thanks a lot for your help rollis13!

I have just made a change as this piece of the code seemed not be storing the variables I needed!

I used:
VBA Code: 
OnDuty = Range("B3").Value
    OffDuty = Range("C3").Value
    Rotations = Range("D3").Value
 
Upvote 0
Zot said:
This is some quick and dirty code since I think it is not well written but tested okay ?

You need to put it under the worksheet Planilha1 (not in normal module). It is a macro triggered by Change event.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Dim m As Long, n As Long
Dim eRow As Long
Dim rngData As Range

eRow = Cells(Rows.Count, "B").End(xlUp).Row
Set rngData = Range("B5", "C" & eRow)

If Not Intersect(rngData, Target) Is Nothing Then
    If Target.Offset(-1).Value = 0 Then
        m = 4
        While Not m > 145
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            For n = 1 To Range("B" & Target.Row)
                m = m + 1
                If m > 145 Then
                    Application.EnableEvents = True
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
                Select Case n
                    Case 1
                        With Cells(Target.Row, m)
                            .Value = "E"
                            .Font.Bold = True
                            .Font.Color = 65535
                            .Interior.Color = 6968388
                        End With
                    Case Else
                        With Cells(Target.Row, m)
                            .Value = "o"
                            .Font.Bold = False
                            .Font.Color = 0
                            .Interior.Color = 13224393
                        End With
                End Select
            Next
            For n = 1 To Range("C" & Target.Row)
                m = m + 1
                If m > 145 Then
                    Application.EnableEvents = True
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
                Select Case n
                    Case 1
                        With Cells(Target.Row, m)
                            .Value = "D"
                            .Font.Bold = True
                            .Font.Color = 65535
                            .Interior.Color = 6968388
                        End With
                    Case Else
                        With Cells(Target.Row, m)
                            .Value = "h"
                            .Font.Bold = False
                            .Font.Color = 0
                            .Interior.Color = 13431551
                        End With
                End Select
            Next
        Wend
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End If

End Sub
Click to expand...
Hi, Zot! Thanks for your time, I tested but it does not work very well. But a change event on the sheet would be problematic.
 
Upvote 0
CubaRJ said:
I have just made a change as this piece of the code seemed not be storing the variables I needed!
Click to expand...
But this change will always fetch data only from those 3 cells in row 3, weren't you supposed to be free to select a cell somewhere in column E or following columns and on whatever row you needed from row 5 and below ? My coding was for a dynamic choice.
 
Upvote 0
rollis13 said:
But this change will always fetch data only from those 3 cells in row 3, weren't you supposed to be free to select a cell somewhere in column E or following columns and on whatever row you needed from row 5 and below ? My coding was for a dynamic choice.
Click to expand...
Maybe I was not clear in my previous response, sorry!

When I pasted your code I noticed it was not storing the variables OnDuty, OffDuty and Rotations and nothing was happening.

Then using F8 and checking the variables I realized the problem and changed the code and then it started working just fine.
 
Upvote 0
Still can't realize :unsure: what change you have applicated unless your post #1 has a layout different from you project, but never mind as long as it's working; glad having been of some help(y).
 
Upvote 0
rollis13 said:
Still can't realize :unsure: what change you have applicated unless your post #1 has a layout different from you project, but never mind as long as it's working; glad having been of some help(y).
Click to expand...

They are verbatim to what I have here. I will run it again to see anything else happens.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Excel macro for Remove comma's and spaces from a cell and place the data in different cell
Replies
3
Views
1K
JEC
JEC
T
  • Question Question
cycle through multiple sheets
Replies
6
Views
760
ttowncorp
T
R
  • Question Question
Help!
Replies
3
Views
2K
63falcondude
63falcondude

Forum statistics

Threads
1,223,231
Messages
6,170,885
Members
452,364
Latest member
springate

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