|
こんにちは
「数値」のケースは考慮してなかったです。
こちらで試して下さい。
Sub データ照合1()
'「項目1」のデータが「AAA」、「項目2」のデータが「1」の場合、
'「項目2」のセルを赤く表示
Const 項目1_Dat As Variant = "AAA"
Const 項目2_Dat As Variant = 1
Dim 項目1_DatC As Variant
Dim 項目2_DatC As Variant
Dim 項目1_Col As Variant
Dim 項目2_Col As Variant
Dim g As Long
Dim r As Range
Dim newBk As Workbook
With ActiveSheet
項目1_Col = Application.Match("項目1", .Rows(1), 0)
項目2_Col = Application.Match("項目2", .Rows(1), 0)
If IsError(項目1_Col) Then Exit Sub
If IsError(項目2_Col) Then Exit Sub
項目1_DatC = _
IIf(IsNumeric(項目1_Dat), 項目1_Dat, _
Chr(34) & 項目1_Dat & Chr(34))
項目2_DatC = _
IIf(IsNumeric(項目2_Dat), 項目2_Dat, _
Chr(34) & 項目2_Dat & Chr(34))
g = ActiveWindow.ActiveCell.Row
With .Range("IV" & g & ":IV" & .Range("A65536").End(xlUp).Row)
.FormulaR1C1 = _
"=IF(AND(RC" & 項目1_Col & "=" & 項目1_DatC & _
",RC" & 項目2_Col & "=" & 項目2_DatC & _
"),1,"""")"
.Value = .Value
On Error Resume Next
Set r = .SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not r Is Nothing Then
Set newBk = Workbooks.Add
Intersect(r.EntireRow, .Parent.Columns(項目2_Col)) _
.Interior.ColorIndex = 3
r.EntireRow.Copy newBk.Worksheets(1).Range("A1")
newBk.SaveAs ThisWorkbook.Path & "\エラーデータ.xls"
End If
.ClearContents
End With
End With
End Sub
|
|