[[20200522115242]] 『表の該当する文字を含む4行を塗りつぶしたい』(123456) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『表の該当する文字を含む4行を塗りつぶしたい』(123456)

Sub 色付け1()
Dim c

 Dim r As Range
 For Each r In Range("E1", Cells(Rows.count, 1).End(xlUp))
 If InStr(r.Value, "●●") Then c = 6 Else c = 0
 r.Resize(, 4).Interior.ColorIndex = c
 Next
 End Sub

Sub 色付け2()
Dim c

 Dim r As Range
 For Each r In Range("A1", Cells(Rows.count, 1).End(xlUp))
 If InStr(r.Value, "●●") Then c = 6 Else c = 0
 r.Resize(, 4).Interior.ColorIndex = c
 Next
 End Sub

現在上記のような2つのマクロを使用し、リストのA列から4行、E列から4行をそれぞれ塗りつぶしています。
●●の部分は何パターンか存在し、毎回マクロを開いて打ち換えているのですが、できれば別シートのリストの範囲を参照し、そのリストに含まれるものを色付けするように改良したいです。
また、現在マクロが2つに含まれていますが、できれば1つにまとめてリストの該当する文字が含まれる行から4つ(文字がある行はA列とE列のみのため)塗り潰す式にしたいと考えています。
ご助力の程宜しくお願いします。

< 使用 Excel:Excel2016、使用 OS:Windows7 >


 >できれば別シートのリストの範囲を参照し
 Sheets("Sheet2").Range("N1:N5") にしています。

 Sub 色付け3()
    Dim c As Long, i As Long
    Dim r As Range
    For Each r In Range("A1", Cells(Rows.Count, "A").End(xlUp))
        For i = 0 To 4 Step 4
            If Listsearch(r.Offset(, i)) Then c = 6 Else c = 0
            r.Offset(, i).Resize(, 4).Interior.ColorIndex = c
        Next
    Next
 End Sub
 Function Listsearch(r As Range) As Boolean
    Dim c As Range
    For Each c In Sheets("Sheet2").Range("N1:N5")
        If InStr(r.Value, c) Then
            Listsearch = True
            Exit For
        End If
    Next
 End Function

(ピンク) 2020/05/22(金) 13:00


ピンク様 ご回答ありがとうございます。ほぼ試した理想通りの動作をしてくれました。
しかしSheet2のリストなのですが、リスト範囲に空欄が含まれていた場合、リストに該当しない
文字の入力があるセルをすべて塗りつぶしてしまいました。
リストの範囲の空欄を除く場合はどのような式を追加すればよいでしょうか。
ご指導お願いいたします。

(123456) 2020/05/22(金) 14:51


 >リストの範囲の空欄を除く場合はどのような式を追加すればよいでしょうか。 

 If InStr(r.Value, c) Then
     ↓
 If c.Value <> "" And InStr(r.Value, c) Then

(ピンク) 2020/05/22(金) 15:04


 訂正

 If c.Value <> "" And InStr(r.Value, c) Then
      ↓
 If c.Value <> "" And InStr(r.Value, c.Value) Then

(ピンク) 2020/05/22(金) 15:26


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.