【Excel マクロ VBA】あるブックのセルの値を他のブックで検索し、そのセルに色をつける

Excel マクロ 超初心者です。


a.xls というファイルの「A列に存在する条件付きのセル（条件1参照）」で、その値を b.xls というファイルで検索し、同じ値のセルがあればそのセルを赤色にする。

条件1: 「A列に存在する条件付きのセル（条件1参照）」とは、 同じ行のB列のセルの値が0で、且つ同じ行のC列のセルの値が0でない時のみ対象とするものとする。

というマクロを仕事用に作りたいのですが、色々と調べて試してみてもうまく回ってくれません。
どなたかご教示いただけますととても嬉しいです。

どうかよろしくお願いいたします。

No.2 回答者： ママチャリ 回答日時： 2017/06/03 16:03

こんなのは、いかがでしょう。

a.xlsmに下記のマクロを登録します。
a.xlsmとb.xlsxの両方のブックを開き、a.xlsmの条件が入力されているシートをアクティブにした状態で、マクロを実行してください。
ちなみに、このマクロは、b.xlsxのSheet1に条件付き書式を設定します。

Sub sample()
Dim i As Long
With Workbooks("b.xlsx").Sheets("Sheet1").Cells.FormatConditions
.Delete
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "B").Value = 0 And Cells(i, "C").Value <> 0 Then
.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=Cells(i, "A").Value
With .Item(.Count).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End If
Next i
End With
End Sub

No.1 回答者： WindFaller 回答日時： 2017/06/01 17:23

こんにちは。

最初に質問とは関係がありませんが、この質問に対して、得意な人もいるはずですが、手間が掛かるので敬遠されがちです。こういう場合、画像を見せイメージを与えると人は回答しようという方が出てくることが多いです。

'-----------
任意のセルに検索値を置いてください。
もう一つのブックを調べて検索します。開いてなくても、自動的に検索するようには出来ていますが、若干誤動作のような、検索してくれないことがあるので、最初に開いておいたほうがよいです。

条件については、下のコードを読んでみてください。
若干、修正が必要な部分があるかもしれません。

'//標準モジュール
Sub SearchValwithCondi()
　Dim wb As Workbook
　Dim c As Range
　Dim sh As Worksheet
　Dim msg As String
　Dim myS_txt As Variant
　Dim cnt As Long
　Dim FirstAddress As String
　With ThisWorkbook.ActiveSheet
　　myS_txt = ActiveCell.Value
　　If myS_txt = "" Then
　　　MsgBox "検索データの所にカーソルを置いてください。", vbExclamation
　　　Exit Sub
　　End If
　End With
　On Error GoTo ErrHandler
　Set wb = Workbooks("b.xls")
　For Each sh In wb.Worksheets
　　With sh.UsedRange.Columns(1)
　　　Set c = .Find( _
　　　　　　　What:=myS_txt, _
　　　　　　　LookIn:=xlValues, _
　　　　　　　LookAt:=xlWhole, _
　　　　　　　SearchOrder:=xlByColumns)
　　　If Not c Is Nothing Then
　　　　FirstAddress = c.Address & sh.Name
　　　　Do
　　　　　'条件設定
　　　　　''c.Interior.ColorIndex = xlColorIndexNone '最初に色付きのセルを消す時
　　　　　If c.Offset(, 1).Text = 0 And c.Offset(, 2).Value <> 0 Then
　　　　　　c.Interior.ColorIndex = 3
　　　　　　If msg = "" Then
　　　　　　 msg = sh.Name & "!" & c.Address(0, 0)
　　　　　　Else
　　　　　　 msg = msg & vbCrLf & sh.Name & "!" & c.Address(0, 0)
　　　　　　End If
　　　　　　cnt = cnt + 1
　　　　　End If
　　　　　Set c = .FindNext(c)　'
　　　　Loop While Not c Is Nothing And c.Address & sh.Name <> FirstAddress
　　　 End If
　　 End With
　　　FirstAddress = ""
　　Next
　　If cnt > 0 Then
　　MsgBox cnt & "個見つかりました" & vbCrLf & msg, vbInformation
　　Else
　　MsgBox "見つかりませんでした", vbExclamation
　　End If
　　Exit Sub
ErrHandler:
　　Workbooks.Open ThisWorkbook.Path & "\b.xls"
　　Set wb = Workbooks("b.xls")
　　Resume Next
　End Sub