Здравствуйте, помогите решить задачу средствами VBA. При вводе значения в ячейку E2, значения в диапазоне C7:E должны выделяться красным цветом. В примере есть макрос, который выполняет поиск дубликатов по значению из E2, а точнее, протягивает формулу в диапазоне A7:A, которая осуществляет поиск в диапазоне C7:E. Возможно его нужно доработать.
Код
Sub Fill()
Application.ScreenUpdating = False
If [E2] <> 0 Then
Dim SRow&
Dim SRowD&
Dim SRowE&
SRow = Cells(Rows.Count, 3).End(xlUp).Row
SRowD = Cells(Rows.Count, 4).End(xlUp).Row
SRowE = Cells(Rows.Count, 5).End(xlUp).Row
If SRow < SRowD Then SRow = SRowD
If SRow < SRowE Then SRow = SRowE
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
SRow = IIf(SRow < 7, 7, SRow)
If SRow > 7 Then
Range("A7").FormulaArray = "=--ISNA(MATCH(999,SEARCH(R2C5,RC[2]:RC[4]),1))"
Range("A7").Copy: Range("A8:A" & SRow).PasteSpecial Paste:=xlPasteFormulas
End If
Application.CutCopyMode = False
[E2].Select
Else
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E2")) Is Nothing And Target.Count = 1 Then
Dim iRng As Range, iAddr$
With Range("C7:E" & Me.UsedRange.Rows.Count)
Set iRng = .Find(Target.Value, LookIn:=xlValues)
If Not iRng Is Nothing Then
iAddr = iRng.Address
Do
iRng.Font.ColorIndex = 3
Set iRng = .FindNext(iRng)
Loop While Not iRng Is Nothing And iRng.Address <> iAddr
End If
End With
End If
End Sub
Согласие есть продукт при полном непротивлении сторон