Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
1行おきの塗りつぶし VBA
投稿日時: 23/12/17 17:05:25
投稿者: み-1108

いつもお世話になりありがとうございます。
1行おきに該当があれば塗りつぶしをしたいと思っております。
 
ws1・・・マスタ
ws2・・・色付けされるシート
 
1行はできたのですが、これを1行おきに実行するにはどうしたらよいのでしょうか。
どなたかよろしくお願いいたします。
 
Sub 塗りつぶし()
 
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long
    Dim lastcolumn1 As Long
    Dim lookupResult As Variant
    
     
    ' シート1とシート2を設定
    Set ws1 = ThisWorkbook.Sheets("マスタ") 'マスタ
    Set ws2 = ThisWorkbook.Sheets("表示") '色付けされるシート
   
   
 ' ===========================================================
     
    ' シート2の最終列を取得
     
    lastcolumn1 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
     
    ' VLOOKUP関数を評価してセルに値を設定
    For i = 1 To lastcolumn1 ' A1から1行目の最終列までの範囲をカバー
        
        lookupResult = Application.VLookup(ws2.Cells(1, i).Value, ws1.Range("A:B"), 2, False)
         
         
        ' 検索結果をセルに設定
        If Not IsError(lookupResult) Then
            
         Select Case lookupResult
             
            Case "1月"
                ws2.Cells(1, i).Interior.ColorIndex = 3
                             
            Case "2月"
                ws2.Cells(1, i).Interior.ColorIndex = 5
                 
            Case "3月"
                ws2.Cells(1, i).Interior.ColorIndex = 6
                 
            Case "4月"
                ws2.Cells(1, i).Interior.ColorIndex = 7
 
            Case "5月"
                ws2.Cells(1, i).Interior.ColorIndex = 8
                  
            Case "6月"
                ws2.Cells(1, i).Interior.ColorIndex = 10
                  
            Case "7月"
                ws2.Cells(1, i).Interior.ColorIndex = 13
                 
            Case "8月"
                ws2.Cells(1, i).Interior.ColorIndex = 17
                  
            Case "9月"
                ws2.Cells(1, i).Interior.ColorIndex = 19
                 
            Case "10月"
                ws2.Cells(1, i).Interior.ColorIndex = 24
                  
            Case "11月"
                ws2.Cells(1, i).Interior.ColorIndex = 39
                  
            Case "12月"
                ws2.Cells(1, i).Interior.ColorIndex = 45
                 
          End Select
                
       End If
    Next i
'=======================================================================
 
End Sub

回答
投稿日時: 23/12/17 18:34:15
投稿者: WinArrow

質問
  
Vlookupで取得した「lookupResult」を
ws2シートのセルには代入していないと思いますが、
このFor 〜 Nextを「1行おき」に実行するのでしょうか?
 
 

投稿日時: 23/12/17 19:07:50
投稿者: み-1108

WinArrow さんの引用:
質問
  
Vlookupで取得した「lookupResult」を
ws2シートのセルには代入していないと思いますが、
このFor 〜 Nextを「1行おき」に実行するのでしょうか?
 
 

 
vlookupの値は代入せずに セルの塗りつぶしをしたいと思っています。
 
For 〜 Next を1行おきに ws2のA列が空白になるまで実行したいのです。
 
よろしくお願いいたします。
 

回答
投稿日時: 23/12/17 21:37:35
投稿者: WinArrow

参考コード
 

Sub 塗りつぶし()
 
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long
    Dim lastcolumn1 As Long
    Dim lookupResult As Variant
    Dim Rx As Long, LastRow As Long
    Dim ColorTBL
    
    ' シート1とシート2を設定
    Set ws1 = ThisWorkbook.Sheets("マスタ") 'マスタ
    Set ws2 = ThisWorkbook.Sheets("表示") '色付けされるシート
    
    ColorTBL = Array(3, 5, 6, 7, 8, 10, 13, 17, 19, 24, 39, 45)
       
 ' ===========================================================
     With ws1
        For Rx = 1 To .Range("A" & .Rows.Count).End(xlUp).Row Step 2
    ' シート2の最終列を取得
        
            lastcolumn1 = ws2.Cells(Rx, Columns.Count).End(xlToLeft).Column
     
    ' VLOOKUP関数を評価してセルに値を設定
            For i = 1 To lastcolumn1 ' A1から1行目の最終列までの範囲をカバー
        
                lookupResult = Application.VLookup(.Cells(Rx, i).Value, ws1.Range("A:B"), 2, False)
         
                     
        ' 検索結果をセルに設定
                If Not IsError(lookupResult) Then
                    .Cells(Rx, i).Interior.ColorIndex = ColorTBL(Val(lookupResult) - 1)
                End If
            Next i
'=======================================================================
        Next
    End With
End Sub

 
※列ループの外側に行ループを追加
※行ウープは1行おき
※列ループ(内側リープ)の中の色番号を配列に格納して
 Vlookup取得値の最初も数字を数値化(VAL関数)して配列の添え字にする
 結果、Select Case をやめた。
※テストはしてありませんので、不具合がでたら、修正してください。
※コードをコピペして終わりではなく、コードの意味を理解してください。
 
 
 

回答
投稿日時: 23/12/17 22:39:48
投稿者: WinArrow

すみません
コードにミスがありました。
修正をお願いします。
 
誤: With ws1
正: With ws2
 
誤: lastcolumn1 = ws2.Cells(Rx, Columns.Count).End(xlToLeft).Column
正: lastcolumn1 = .Cells(Rx, Columns.Count).End(xlToLeft).Column

投稿日時: 23/12/18 16:03:52
投稿者: み-1108

WinArrow 様
ご教授ありがとうございました。
初めて見るコードもあり大変勉強になりました。
 
無事に解決いたしました。ありがとうございました。