[[20240228132324]]　『土日の列だけ、背景色をVBAで色付けしたい』（キントン）　ページの最後に飛ぶ

『土日の列だけ、背景色をVBAで色付けしたい』（キントン）

勤務表の土日の列に色付けをVBAで行いたいです。（今は、条件付き書式で行っている。）

D4:AH4　に日付
D5：AH5　に曜日
D8：Ah28　には、各スタッフのシフトが入力される

色付け行う範囲としては、列がD～AH　　行が４～２３
黄色で色付けを行いたいです

分かる方、教えてください…。

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

ちなみに、条件付き書式で行った場合、場合によっては上から色を付けたい事があります。
でも条件付き書式だと上塗りはできないのでVBAで対処したいです。
（キントン） 2024/02/28(水) 14:29:30

4行目のセルが日付型だとして簡単に...

Sub TSET()

    '変数宣言
    Dim c As Long '列番号

    'D4~AH23のセルを塗りつぶし無しに設定(不要ならコメントアウトまたは削除)
    Range("D4:AH23").Interior.ColorIndex = 0

    '4列目(D列)から34列目(AH列)までループ処理
    For c = 4 To 34

        '4行目のセルの値を参照し、Weekday関数の結果が日曜日(1)または土曜日(7)の場合
        If Weekday(Cells(4, c).Value) = 1 Or Weekday(Cells(4, c).Value) = 7 Then

            '4行目から23行目のセルを塗りつぶす
            Range(Cells(4, c), Cells(23, c)).Interior.ColorIndex = 6 '6:黄色 36:薄い黄色

        End If
    Next c
End Sub
（む） 2024/02/28(水) 14:42:09

 かぶっちゃったけどそのまま

 たしかにそういうこともあるかも知れないですね

 Sub sample()
    Dim aCol As Range
    For Each aCol In Range("D4:AH23").Columns
      If Weekday(aCol.Cells(1).Value, vbMonday) >= 6 Then
         aCol.Interior.Color = vbYellow
      End If
    Next
 End Sub
（´・ω・`） 2024/02/28(水) 14:48:18

お二方、ありがとうございます。
うまく出来ました。

ちなみに、月を変更するごとにマクロの自動更新は、可能でしょうか？
今のままだと、月が変更になった場合、前月の色がそのままになってしまうので…。

無理言ってすいません…
（キントン） 2024/02/28(水) 14:59:19

＞今のままだと
その表をカレンダーにしてください。
（?） 2024/02/28(水) 15:06:10

 月が変わったら上書きするのじゃなくて、
 色のついてないテンプレートを用意して、月替わりに新規シートを作成しましょう

 過去データっていうのは消さずに蓄積しておくものです
（´・ω・`） 2024/02/28(水) 15:41:26

そうですね。ご忠告ありがとうございます。
日曜日のみ色付けする場合は、

 If Weekday(aCol.Cells(1).Value, vbMonday) >= 6 Then

↑どこを変更すればよいでしょうか？
（キントン） 2024/02/28(水) 16:08:55

 If Weekday(aCol.Cells(1).Value, vbMonday) = 7 Then

＞＝６を＝７です。
（四国三郎） 2024/02/28(水) 18:46:49

 ちょい脱線 (というか... 何? 余興? ^^;)

 >条件付き書式だと上塗りはできない
 ていう部分を優先するならば

 「パターンで誤魔化す」という手もありますぜ。

        ...はい。あんまキレイじゃないのは分かってて言ってますとも。
                 キレイじゃないって事は目には逆効果ですからね。実務には向かないスけどね。^^;

    Sub 不向きの実証()
        Const RGB_FORE = &H40FFFF  '←淡色系ならそこそこイケると思ったのだが
        Rows.Clear
        Call ExecPaint([A1:C8], RGB_FORE, xlPatternGray50, 0.5!)
        [B1] = "Gray50"
        [C1] = "50%"
        Call ExecPaint([D1:F8], RGB_FORE, xlPatternGray75, 0.75!)
        [E1] = "Gray75"
        [F1] = "75%"
        Call ExecPaint([G1:I8], RGB_FORE, xlPatternGray25, 0.25!)
        [H1] = "Gray25"
        [I1] = "25%"
        Call ExecPaint([J1:L8], RGB_FORE, xlPatternGray16, 0.125!)
        [K1] = "Gray16"
        [L1] = "12.5%"
        Call ExecPaint([M1:O8], RGB_FORE, xlPatternGray8, 0.0625!)
        [N1] = "Gray8"
        [O1] = "6.25%"
        Call ExecPaint([P1:R8], RGB_FORE, xlPatternSemiGray75, 0.75!)
        [Q1] = "SemiGray75"
        [R1] = "75%"
        '*** 乗算で追試 ***
        Call ExecPaint([A11:C18], RGB_FORE, xlPatternGray50, 0.5!, True)
        [B11] = "Gray50"
        [C11] = "50%"
        Call ExecPaint([D11:F18], RGB_FORE, xlPatternGray75, 0.75!, True)
        [E11] = "Gray75"
        [F11] = "75%"
        Call ExecPaint([G11:I18], RGB_FORE, xlPatternGray25, 0.25!, True)
        [H11] = "Gray25"
        [I11] = "25%"
    End Sub
    Private Sub ExecPaint(rng As Range, frgb As OLE_COLOR, ptn As XlPattern, alp As Single, Optional Multiply As Boolean)
        With ActiveWorkbook.Theme.ThemeColorScheme
            rng.Rows(2).Interior.Color = .Colors(msoThemeAccent1).RGB
            rng.Rows(3).Interior.Color = .Colors(msoThemeAccent2).RGB
            rng.Rows(4).Interior.Color = .Colors(msoThemeAccent3).RGB
            rng.Rows(5).Interior.Color = .Colors(msoThemeAccent4).RGB
            rng.Rows(6).Interior.Color = .Colors(msoThemeAccent5).RGB
            rng.Rows(7).Interior.Color = .Colors(msoThemeAccent6).RGB
        End With
        With rng.Columns(2).FormatConditions.Add(Type:=xlExpression, Formula1:="=TRUE")
            .Interior.Pattern = ptn
            .Interior.PatternColor = frgb
            .StopIfTrue = False
        End With
        Dim c As Range
        For Each c In rng.Columns(3).Rows
            If Multiply Then
                c.Interior.Color = AlphaBlend(c.Interior.Color, MultiplyBlend(c.Interior.Color, frgb), alp)
            Else
                c.Interior.Color = AlphaBlend(c.Interior.Color, frgb, alp)
            End If
        Next
    End Sub
    Private Function AlphaBlend(BackRGB As OLE_COLOR, ForeRGB As OLE_COLOR, ByVal Alpha As Single) As OLE_COLOR
        Dim Back() As Variant, Fore() As Variant, i As Long, vRGB(0 To 2) As Long
        Back = SplitRGB(BackRGB)
        Fore = SplitRGB(ForeRGB)
        If Alpha < 0 Then Alpha = 0
        If Alpha > 1 Then Alpha = 1
        For i = 0 To 2
            vRGB(i) = Back(i) * (1 - Alpha) + Fore(i) * Alpha
            If vRGB(i) > &HFF& Then vRGB(i) = &HFF&
        Next
        AlphaBlend = vRGB(0) Or vRGB(1) * &H100& Or vRGB(2) * &H10000
    End Function
    Private Function MultiplyBlend(BackRGB As OLE_COLOR, ForeRGB As OLE_COLOR) As OLE_COLOR
        Dim Back() As Variant, Fore() As Variant, i As Long, vRGB(0 To 2) As Long
        Back = SplitRGB(BackRGB)
        Fore = SplitRGB(ForeRGB)
        For i = 0 To 2
            vRGB(i) = Fore(i) * Back(i) / &HFF&
            If vRGB(i) > &HFF& Then vRGB(i) = &HFF&
            If vRGB(i) < &H0& Then vRGB(i) = &H0&
        Next
        MultiplyBlend = vRGB(0) Or vRGB(1) * &H100& Or vRGB(2) * &H10000
    End Function
    Private Function SplitRGB(aRGB As OLE_COLOR) As Variant
        Dim ary(0 To 2) As Variant, i As Long
        For i = 0 To 2
            ary(i) = (aRGB And &HFF& * &H100& ^ i) \ &H100& ^ i
        Next
        SplitRGB = ary
    End Function

（白茶） 2024/02/28(水) 22:31:09

コメント返信：

[ 一覧(最新更新順) ]

[[20240228132324]] 『土日の列だけ、背景色をVBAで色付けしたい』（キントン） ページの最後に飛ぶ

[[20240228132324]]　『土日の列だけ、背景色をVBAで色付けしたい』（キントン）　ページの最後に飛ぶ