Excel VBA質問箱 IV

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

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


6692 / 13644 ツリー ←次へ | 前へ→

【43672】条件2個つきのセルの色付けについて ミク 06/10/22(日) 17:54 質問[未読]
【43673】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 17:57 発言[未読]
【43677】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 18:15 質問[未読]
【43678】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 18:40 発言[未読]
【43680】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 19:26 質問[未読]
【43685】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 20:31 発言[未読]
【43686】Re:条件2個つきのセルの色付けについて ponpon 06/10/22(日) 23:03 発言[未読]
【43688】Re:条件2個つきのセルの色付けについて ichinose 06/10/23(月) 8:00 発言[未読]
【43737】Re:条件2個つきのセルの色付けについて ミク 06/10/24(火) 12:41 お礼[未読]
【43681】Re:条件2個つきのセルの色付けについて ichinose 06/10/22(日) 19:30 発言[未読]
【43682】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 19:52 質問[未読]
【43683】Re:条件2個つきのセルの色付けについて ichinose 06/10/22(日) 20:06 発言[未読]
【43676】Re:条件2個つきのセルの色付けについて Kein 06/10/22(日) 18:12 回答[未読]
【43687】Re:条件2個つきのセルの色付けについて Hirofumi 06/10/22(日) 23:05 回答[未読]

【43672】条件2個つきのセルの色付けについて
質問  ミク  - 06/10/22(日) 17:54 -

引用なし
パスワード
   はじめまして。

成績順で並び替えた後に、
("B1:B9")ならびに("D1:D9")
へ共に入ってきているメンバーのセルのみを
色付け。あるいは、全く別のセルに書き込み
させたいのですが、うまくいきません・・・

回答いただけますと幸いです。
よろしくお願いします。

【43673】Re:条件2個つきのセルの色付けについて
発言  かみちゃん  - 06/10/22(日) 17:57 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>成績順で並び替えた後に、
>("B1:B9")ならびに("D1:D9")
>へ共に入ってきているメンバーのセルのみを
>色付け。あるいは、全く別のセルに書き込み
>させたい

シートイメージがよくわかりません。
お手数ですが、以下のようなイメージで説明していただけませんか?
  A  B  C  D  E
1
2
3
4

※シートイメージを投稿の際は、内容欄の右下の「等幅」にチェックをしてください。

【43676】Re:条件2個つきのセルの色付けについて
回答  Kein  - 06/10/22(日) 18:12 -

引用なし
パスワード
   こーいうことかな・・?

Sub Check()
  Dim MyR As Range, C As Range
 
  Set MyR = Range("B1:C9")
  MyR.Interior.ColorIndex = xlColorIndexNone
  For Each C In MyR
   If WorksheetFunction _
   .CountIf(MyR, C.Value) > 1 Then
     C.Interior.ColorIndex = 6
   End If
  Next
  Set MyR = Nothing
End Sub

【43677】Re:条件2個つきのセルの色付けについて
質問  ミク  - 06/10/22(日) 18:15 -

引用なし
パスワード
   ▼かみちゃん さん:
>こんにちは。かみちゃん です。
>
>>成績順で並び替えた後に、
>>("B1:B9")ならびに("D1:D9")
>>へ共に入ってきているメンバーのセルのみを
>>色付け。あるいは、全く別のセルに書き込み
>>させたい
>
>シートイメージがよくわかりません。
>お手数ですが、以下のようなイメージで説明していただけませんか?
>  A  B  C  D  E
>1
>2
>3
>4
>
>※シートイメージを投稿の際は、内容欄の右下の「等幅」にチェックをしてください。

こんにちは。
文章のみでわかりにくくて申し訳ありませんでした。


  A    B    C    D
1 人名a  121   人名a   222
2 人名b  312   人名b   536
3 人名c  564   人名c   145
4 人名d  228   人名d   343

の2つの表をまずそれぞれ数値の高い順に並び替え

  A    B    C    D
1 人名c  564   人名b   536
2 人名b  312   人名d   343
3 人名d  228   人名a   222
4 人名a  121   人名c   145

となった場合に、(ここまでは出来ているのですが)

例として2つの表で共に上位2位に入ってきている人
ここでは人名bのセル("A2")("C2")を色づけと思っています。
あるいは人名bをセル("A6")等に表示させたいと思っています。

【43678】Re:条件2個つきのセルの色付けについて
発言  かみちゃん  - 06/10/22(日) 18:40 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>例として2つの表で共に上位2位に入ってきている人
>ここでは人名bのセル("A2")("C2")を色づけと思っています。

最終結果は、並べ替えた状態がいいのですか?
並べ替えなくても、以下のような方法でできます。
なお、同じ数値の場合は、それぞれに色をつけます。

Sub Test()
 Dim intCol As Integer
 Dim intData As Integer
 Dim c As Range
 Dim FirstAddress As String
 
 For intCol = 2 To 4 Step 2
  Columns(intCol).Offset(, -1).Interior.ColorIndex = xlColorIndexNone
  '2番目に大きい値を取得する(LARGEワークシート関数を利用)
  intData = Application.WorksheetFunction.Large(Columns(intCol), 2)
  With Columns(intCol).Cells
   Set c = .Find(intData, LookIn:=xlValues, LookAt:=xlWhole)
   If Not c Is Nothing Then
    FirstAddress = c.Address
    Do
     c.Offset(, -1).Interior.ColorIndex = 6
     Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAddress
   End If
  End With
 Next
 MsgBox "終了しました"
End Sub

【43680】Re:条件2個つきのセルの色付けについて
質問  ミク  - 06/10/22(日) 19:26 -

引用なし
パスワード
   こんにちは。

>ここでは人名bのセル("A2")("C2")を色づけと思っています。
間違っていました・・・

人名bのセル("A2")("C1")を色づけと思っています。でした・・・
意味がわかりにくくて申し訳ありませんでした・・・

表1で上位2番目以内。且つ。表2で上位2番目以内
を色づけというパターンです・・・

   B  C  D  E  F  G
7  人名a 23        人名a 111
8  人名b 12        人名b 222
9  人名c 14        人名c 121
10 人名d 21        人名d 212
11 人名e 22        人名e 311
12 人名f 111       人名f 123
13 人名g 222       人名g 321
14 人名h 333       人名h 221
15 人名i 444       人名i 234
16 人名j 555       人名j 432
17 人名k 666       人名k 101
18 人名l 777       人名l 555
19 人名m 888       人名m 666
20 人名n 999       人名n 777
21 人名o 129       人名o 120
22 人名p 138       人名p 200
23 人名q 397       人名q 146
24 人名r 222       人名r 450

と実際の表があるのですが(a/d/e列)・(1〜6)は空白です
左の表では人名f/g/h/i/j/k/l/m/nが上位9人
右の表では人名b/e/g/i/j/l/m/n/rが上位9人
共に上位9人に入っている人が
人名g/i/j/l/m/nの6人(ここは他表では人数の上下が出てきますが)
となりこの6人(共に上位9人に入っているメンバー)を
色付けしたいと思っています。

【43681】Re:条件2個つきのセルの色付けについて
発言  ichinose  - 06/10/22(日) 19:30 -

引用なし
パスワード
   こんばんは。

>の2つの表をまずそれぞれ数値の高い順に並び替え
>  A    B    C    D
>1 人名c  564   人名b   536
>2 人名b  312   人名d   343
>3 人名d  228   人名a   222
>4 人名a  121   人名c   145
>
>となった場合に、(ここまでは出来ているのですが)
>
>例として2つの表で共に上位2位に入ってきている人
>ここでは人名bのセル("A2")("C2")を色づけと思っています。
これ、人名bのセル("A2")("C1")を色づけ ですね!!

アクティブシートに上記のように並び替えられた表があるとすると、
条件付書式での設定をVBAで行ってみました

'==============================================================
Sub main()
  Dim rng1 As Range
  Dim rng2 As Range
  Const 調査順位 As Long = 2
  Range("a:a,c:c").FormatConditions.Delete
  Set rng1 = Range("a1:a" & 調査順位)
  Set rng2 = Range("c1:c" & 調査順位)
  With rng1
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng2.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
  With rng2
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng1.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
End Sub

上記は、上位2位までを調査対象にしました。
試してみてください。

【43682】Re:条件2個つきのセルの色付けについて
質問  ミク  - 06/10/22(日) 19:52 -

引用なし
パスワード
   ▼ichinose さん:
>こんばんは。
>
>>の2つの表をまずそれぞれ数値の高い順に並び替え
>>  A    B    C    D
>>1 人名c  564   人名b   536
>>2 人名b  312   人名d   343
>>3 人名d  228   人名a   222
>>4 人名a  121   人名c   145
>>
>>となった場合に、(ここまでは出来ているのですが)
>>
>>例として2つの表で共に上位2位に入ってきている人
>>ここでは人名bのセル("A2")("C2")を色づけと思っています。
>これ、人名bのセル("A2")("C1")を色づけ ですね!!
>
>アクティブシートに上記のように並び替えられた表があるとすると、
>条件付書式での設定をVBAで行ってみました
>
>'==============================================================
>Sub main()
>  Dim rng1 As Range
>  Dim rng2 As Range
>  Const 調査順位 As Long = 2
>  Range("a:a,c:c").FormatConditions.Delete
>  Set rng1 = Range("a1:a" & 調査順位)
>  Set rng2 = Range("c1:c" & 調査順位)
>  With rng1
>    .FormatConditions.Add Type:=xlExpression, Formula1:= _
>    "=countif(" & rng2.Address(, , xlR1C1) & ",rc)"
>    .FormatConditions(1).Interior.ColorIndex = 6
>    End With
>  With rng2
>    .FormatConditions.Add Type:=xlExpression, Formula1:= _
>    "=countif(" & rng1.Address(, , xlR1C1) & ",rc)"
>    .FormatConditions(1).Interior.ColorIndex = 6
>    End With
>End Sub
>
>上記は、上位2位までを調査対象にしました。
>試してみてください。

こんばんは。
入力後実施してみました。
すると、A、C共に同じ文字(数値)のセルが
色づけされました。(名前は変わりませんので全ての方に
色がついてしまいました。)

【43683】Re:条件2個つきのセルの色付けについて
発言  ichinose  - 06/10/22(日) 20:06 -

引用なし
パスワード
   >入力後実施してみました。
>すると、A、C共に同じ文字(数値)のセルが
>色づけされました。(名前は変わりませんので全ての方に
>色がついてしまいました。)

では、新規ブック(あくまでも新規ブックです)の標準モジュールに

'====================================================
Sub mk_sample()
  Range("a1:d1").Value = Array("人名c", 564, "人名b", 536)
  Range("a2:d2").Value = Array("人名b", 312, "人名d", 343)
  Range("a3:d3").Value = Array("人名d", 228, "人名a", 222)
  Range("a4:d4").Value = Array("人名a", 121, "人名c", 145)
  
End Sub
'================================================================

Sub main()
  Dim rng1 As Range
  Dim rng2 As Range
  Const 調査順位 As Long = 2
  Range("a:a,c:c").FormatConditions.Delete
  Set rng1 = Range("a1:a" & 調査順位)
  Set rng2 = Range("c1:c" & 調査順位)
  With rng1
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng2.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
  With rng2
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng1.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
End Sub


として、何も入力されていないシートをアクティブにして

mk_sampleを実行してみてください。

ミクさんが例題データとして記述された

>>  A    B    C    D
>>1 人名c  564   人名b   536
>>2 人名b  312   人名d   343
>>3 人名d  228   人名a   222
>>4 人名a  121   人名c   145

このデータが表示されますよね。

このデータに対して、
mainを実行してみてください。

セルA2、C1の人名bだけが黄色に塗りつぶされるはずですが・・・。

再度、確認してみてください。

【43685】Re:条件2個つきのセルの色付けについて
発言  かみちゃん  - 06/10/22(日) 20:31 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>左の表では人名f/g/h/i/j/k/l/m/nが上位9人
>右の表では人名b/e/g/i/j/l/m/n/rが上位9人
>共に上位9人に入っている人が
>人名g/i/j/l/m/nの6人(ここは他表では人数の上下が出てきますが)
>となりこの6人(共に上位9人に入っているメンバー)を
>色付けしたい

・9位の人が複数いた場合どうするのかわからない
・私の発想が乏しく、複雑なコードしか思い浮かばない
・ichinoseさんからの提案で対応できそう
ということで、勝手で申し訳ないのですが、ちょっと静観させていただきたいと思います。

【43686】Re:条件2個つきのセルの色付けについて
発言  ponpon  - 06/10/22(日) 23:03 -

引用なし
パスワード
   私も作ってみました。
上位9位なのか、2位なのかよくわかりませんでしたが、
上位9位でやってます。
表は並べ替えしていないと考えています。

Sub Macro1()
  Dim myVal, myVal2
  Dim i As Long, j as Long
  Dim myRnk As Long
  
  myRnk = 9
  With Sheets("Sheet1")
    .Cells.Interior.ColorIndex = xlNone
    .Range("B7", .Range("C65536").End(xlUp)).Sort Key1:=.Range("C7"), _
                   Order1:=xlDescending, Header:=xlGuess
    .Range("F7", .Range("G65536").End(xlUp)).Sort Key1:=.Range("G7"), _
                   Order1:=xlDescending, Header:=xlGuess
      
    myVal = .Range("B7", .Range("B65536").End(xlUp)).Value
    myVal2 = .Range("F7", .Range("F65536").End(xlUp)).Value
     
    For i = 1 To myRnk
     For j = 1 To myRnk
       If myVal(i, 1) = myVal2(j, 1) Then
        .Cells(i + 6, 2).Interior.ColorIndex = 3
        .Cells(j + 6, 6).Interior.ColorIndex = 3
       End If
     Next
    Next
  End With
End Sub

【43687】Re:条件2個つきのセルの色付けについて
回答  Hirofumi  - 06/10/22(日) 23:05 -

引用なし
パスワード
   上位9人の見解の相異かな?
同点の場合が有るので、人名rも入るのかな?

Option Explicit

Public Sub DataMatch()

  '科目1のデータ列数(B列〜C列)
  Const clngColumns1 As Long = 2
  '科目1の「氏名」の有る列位置(基準位置からの列Offset「C列」)
  Const clngKeys1 As Long = 0
  '科目2のデータ列数(F列〜G列)
  Const clngColumns2 As Long = 2
  '科目2の「氏名」の有る列位置(基準位置からの列Offset「G列」)
  Const clngKeys2 As Long = 0
  '出力するRankの最大値
  Const clngLimit As Long = 9
  
  Dim i As Long
  Dim rngList1 As Range, rngList2 As Range
  Dim vntList1 As Variant, vntList2 As Variant
  Dim lngRows1 As Long, lngRows2 As Long
  Dim dicIndex As Object
  Dim lngColor As Long
  Dim lngCount As Long
  Dim lngRank As Long
  Dim lngMark As Long
  Dim strProm As String

  '科目1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(6, "B")
  
  '科目2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet1").Cells(6, "F")
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '科目1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, clngKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '科目2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, clngKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '科目1の基準に就いて
  With dicIndex
    'Rankの初期値
    lngRank = 1
    '人数の初期値
    lngMark = 1
    '科目1の上位者をDictionaryに登録
    .Item(vntList1(1, 1)) = 1
    For i = 2 To lngRows1
      '人数を更新
      lngMark = lngMark + 1
      '点数が前と違った場合
      If vntList1(i, 2) <> vntList1(i - 1, 2) Then
        'Rankの更新
        lngRank = lngMark
      End If
      '指定Rankの者までを登録
      If lngRank <= clngLimit Then
        .Item(vntList1(i, 1)) = i
      Else
        Exit For
      End If
    Next i
  End With
  
  '科目2の基準に就いて
  With dicIndex
    'Rankの初期値
    lngRank = 1
    '人数の初期値
    lngMark = 1
    '科目1の上位者名と同じならBuckColorを変更
    If .Exists(vntList2(1, 1)) Then
      'ColorIndexを更新
      lngColor = 33 + (lngCount Mod 16)
      '科目1に色付け
      rngList1.Offset(.Item(vntList2(1, 1))).Interior.ColorIndex = lngColor
      '科目2に色付け
      rngList2.Offset(1).Interior.ColorIndex = lngColor
      '次のColorIndexに
      lngCount = lngCount + 1
    End If
    For i = 2 To lngRows2
      '人数を更新
      lngMark = lngMark + 1
      '点数が前と違った場合
      If vntList2(i, 2) <> vntList2(i - 1, 2) Then
        'Rankの更新
        lngRank = lngMark
      End If
      '指定Rankの者までを登録
      If lngRank <= clngLimit Then
        .Item(vntList1(i, 1)) = i
        If .Exists(vntList2(i, 1)) Then
          'ColorIndexを更新
          lngColor = 33 + (lngCount Mod 16)
          '科目1に色付け
          rngList1.Offset(.Item(vntList2(i, 1))).Interior.ColorIndex = lngColor
          '科目2に色付け
          rngList2.Offset(i).Interior.ColorIndex = lngColor
          '次のColorIndexに
          lngCount = lngCount + 1
        End If
      Else
        Exit For
      End If
    Next i
  End With
  
  
  '科目1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  '科目2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set dicIndex = Nothing
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをlngKeys1列で整列
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
      Key1:=.Offset(1, lngKeys + 1), Order1:=xlDescending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '比較用配列にデータを取得
    vntData = .Offset(1, lngKeys).Resize(lngRows + 1, 2).Value
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
      Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '復帰用Key列を削除
    .Offset(1, lngColumns).EntireColumn.Delete
  End With

End Sub

【43688】Re:条件2個つきのセルの色付けについて
発言  ichinose  - 06/10/23(月) 8:00 -

引用なし
パスワード
   おはようございます。
>同点の場合が有るので、人名rも入るのかな
とHirofumiさんがおっしゃっていますね!!
これを考慮すると・・・。


>   B  C  D  E  F  G
>7  人名a 23        人名a 111
>8  人名b 12        人名b 222
>9  人名c 14        人名c 121
>10 人名d 21        人名d 212
>11 人名e 22        人名e 311
>12 人名f 111       人名f 123
>13 人名g 222       人名g 321
>14 人名h 333       人名h 221
>15 人名i 444       人名i 234
>16 人名j 555       人名j 432
>17 人名k 666       人名k 101
>18 人名l 777       人名l 555
>19 人名m 888       人名m 666
>20 人名n 999       人名n 777
>21 人名o 129       人名o 120
>22 人名p 138       人名p 200
>23 人名q 397       人名q 146
>24 人名r 222       人名r 450

これをB:C列をC列、F:G列をG列で降順に並べ替えると

'=====================================================
     B    C    D    E    F    G
 7  人名n    999            人名n    777
 8  人名m    888            人名m    666
 9  人名l    777            人名l    555
10  人名k    666            人名r    450
11  人名j    555            人名j    432
12  人名i    444            人名g    321
13  人名q    397            人名e    311
14  人名h    333            人名i    234
15  人名r    222            人名b    222
16  人名g    222            人名h    221
17  人名p    138            人名d    212
18  人名o    129            人名p    200
19  人名f    111            人名q    146
20  人名a    23            人名f    123
21  人名e    22            人名c    121
22  人名d    21            人名o    120
23  人名c    14            人名a    111
24  人名b    12            人名k    101

となります(ここまでは出来るのですよね?)
このデータに対して、

標準モジュールに

'==================================================================
Sub main()
  Dim rng1 As Range
  Dim rng2 As Range
  Dim rw1 As Long
  Dim rw2 As Long
  Const 調査順位 As Long = 9
  On Error Resume Next
  With Range("c7", Cells(Rows.Count, 3).End(xlUp))
    rw1 = Evaluate("max(if(" & .Address & "=large(" _
        & .Address & "," & 調査順位 & _
        "),row(" & .Address & ")))")
    If Err.Number <> 0 Then rw1 = .Row + .Rows.Count - 1
    End With
  Err.Clear
  With Range("g7", Cells(Rows.Count, 7).End(xlUp))
    rw2 = Evaluate("max(if(" & .Address & "=large(" _
        & .Address & "," & 調査順位 & _
        "),row(" & .Address & ")))")
    If Err.Number <> 0 Then rw2 = .Row + .Rows.Count - 1
    End With
  Range("b:b,f:f").FormatConditions.Delete
  Set rng1 = Range("b7:b" & rw1)
  Set rng2 = Range("f7:f" & rw2)
  With rng1
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng2.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
  With rng2
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
    "=countif(" & rng1.Address(, , xlR1C1) & ",rc)"
    .FormatConditions(1).Interior.ColorIndex = 6
    End With
  On Error GoTo 0
End Sub

人名rまで塗りつぶし対象になります。

これも試してみてください。

【43737】Re:条件2個つきのセルの色付けについて
お礼  ミク  - 06/10/24(火) 12:41 -

引用なし
パスワード
   こんにちは。

最終投稿後、急にネット接続が出来なくなり
お礼が遅くなり申し訳ありませんでした・・・

皆様のおかげで無事実行することが出来ました。
本当にありがとうございました。

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