Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


14668 / 76738 ←次へ | 前へ→

【67559】Re:4つ以上の条件付書式のマクロ設定
回答  Hirofumi  - 10/12/13(月) 15:48 -

引用なし
パスワード
   今一状況が把握できませんが?
試しに、こんなのでは?
シート2C列のセルのColorIndexを使いますので
シート2C列は、C列の文字に対応するBackColorにして置いて下さい

シート1のシートモジュールは以下のコードを記入します

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim i As Long
  Dim vntFound As Variant
  Dim vntValue As Variant
  Dim rngList As Range

  With Target
    If .Count <> 1 Then Exit Sub
    If Not (.Column = 3 Or .Column = 6 Or .Column = 9) Then Exit Sub
    vntValue = .Value
  End With

  With Worksheets("Sheet2")
    Set rngList = .Range(.Cells(2, "C"), .Cells(Rows.Count, "C").End(xlUp))
    vntFound = Application.Match(vntValue, rngList, 0)
    If Not IsError(vntFound) Then
      Target.Interior.ColorIndex _
          = rngList.Item(vntFound, 1).Interior.ColorIndex
    Else
      Target.Interior.ColorIndex = xlNone
    End If
  End With

  Set rngList = Nothing
  
End Sub

シート2のシートモジュールには以下を記述します

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim vntFound As Variant
  Dim rngList As Range
  
  With Target
    If .Count > 1 Then
      Exit Sub
    End If
    If .Column <> 3 Then
      Exit Sub
    End If
    If IsEmpty(.Value) Then
      Exit Sub
    End If
  End With
  
  With Me
    Set rngList = .Range(.Cells(2, "C"), .Cells(Rows.Count, "C").End(xlUp))
  End With

  With Worksheets("Sheet1")
    lngRows = .UsedRange.Rows.Count
    For i = 3 To 9 Step 3
      For j = 2 To lngRows
        vntFound = Application.Match(.Cells(j, i).Value, rngList, 0)
        If Not IsError(vntFound) Then
          .Cells(j, i).Interior.ColorIndex _
            = rngList.Item(vntFound, 1).Interior.ColorIndex
        Else
          .Cells(j, i).Interior.ColorIndex = xlNone
        End If
      Next j
    Next i
  End With
        
  Set rngList = Nothing
  
End Sub

シート2のC列の値(色名)が変更に成ると
シート1のC、F、I列の色を変更します、因って非常に時間が掛かるかも解りません?
0 hits

【67549】4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 8:27 質問
【67550】Re:4つ以上の条件付書式のマクロ設定 sasa 10/12/13(月) 8:41 回答
【67553】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 10:38 お礼
【67551】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 9:42 回答
【67552】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 10:37 お礼
【67554】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 10:52 発言
【67555】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 11:52 質問
【67556】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 14:34 回答
【67558】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 14:47 回答
【67559】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 15:48 回答
【67562】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 20:07 お礼
【67563】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 20:39 回答
【67564】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 20:59 お礼
【67566】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 21:07 回答
【67565】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 21:05 回答
【67560】Re:4つ以上の条件付書式のマクロ設定 AAA 10/12/13(月) 15:56 質問
【67561】Re:4つ以上の条件付書式のマクロ設定 Hirofumi 10/12/13(月) 16:50 回答

14668 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free