1

Вот что делает мой код: он ищет повторяющиеся записи в столбце A Он применяет цвет к обеим ячейкам при обнаружении дубликата.

Чего я пытаюсь добиться:

  • Уменьшить количество кода
  • Сделайте это коротким и сладким

Sub COLOUR_DOUBLE_ENTRY()

Application.Workbooks(file_name).Worksheets("ms").Activate

last_row = Application.Workbooks(file_name).Worksheets("ms").Range("a65536").End(xlUp).Row

   Application.Workbooks(file_name).Worksheets("ms").Range("A:E").Interior.Pattern = xlNone



For a = 2 To last_row
For b = 1 To last_row

'NAME
 first_item = Application.Workbooks(file_name).Worksheets("ms").Range("b" & a).Value
 secound_item = Application.Workbooks(file_name).Worksheets("ms").Range("b" & b + a).Value

'VALUE
first_item_value = Application.Workbooks(file_name).Worksheets("ms").Range("C" & a).Value
secound_item_value = Application.Workbooks(file_name).Worksheets("ms").Range("C" & b + a).Value


If first_item = secound_item And first_item_value = secound_item_value Then


 Application.Workbooks(file_name).Worksheets("ms").Range("A" & a & ":E" & a).Select

With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 49407
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 Application.Workbooks(file_name).Worksheets("ms").Range("a" & b + a & ":E" & b + a).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 49407
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

End If


Next b
Next a


End Sub

1 ответ1

1

Ваша техника сравнивает пары клеток неоднократно. Вот один из способов избежать двойной петли:

Sub COLOUR_DOUBLE_ENTRY()
   Dim N As Long, wf As WorksheetFunction
   Dim rng As Range, r As Range
   Set wf = Application.WorksheetFunction
   N = Cells(Rows.Count, "A").End(xlUp).Row
   Set rng = Range("A1:A" & N)

   For Each r In rng
      If wf.CountIf(rng, r.Value) > 1 Then
         With r.Interior
             .Pattern = xlSolid
             .PatternColorIndex = xlAutomatic
             .Color = 49407
             .TintAndShade = 0
             .PatternTintAndShade = 0
         End With
      End If
   Next r
End Sub

Конечно, это просто описание техники. Вы можете адаптировать его под свои нужды.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками .