Цикл только видимых строк не работает

Question

Я пытаюсь написать фрагмент кода, который раскрасит все запросы, которые содержат только одно уникальное имя для каждого запроса. Почему не работает циклическое отображение только видимых ячеек?

ОБНОВЛЕНИЕ: Мне нужно удалить строки, если для конкретного запроса назначено только одно имя

Так что для запроса ниже Я хотел бы удалить Мэри Х (так как ее имя появляется только один раз в запросе)

Request Number  Client Contact Assignee: Full Name
4350257 Eleanor B
4350257 Eleanor B
4350257 Mary H

Этот запрос в порядке, нет необходимости удалять что-либо

8620428 Kevin M
8620428 Kevin M

В этом запросе я хотел бы удалить Мэри Х и Джулию К, так как там имена появляются только один раз в запросе)

7208497 Michael W
7208497 Mary H
7208497 Michael W
7208497 Julia K

Мой КОД:

Sub Testing()

Sheet1.Select

Dim r As Long, LR As Long
Dim ReqNo As Long, CCFullName As Long
Dim rgn2 As Range

LR = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

'Request Number
ReqNo = Application.Match("Request Number", Sheet1.Rows(1), 0)
'Client Contact Assignee: Full Name
CCFullName = Application.Match("Client Contact Assignee: Full Name", Sheet1.Rows(1), 0)

Set rgn2 = Columns(CCFullName)

Dim cl As Range, rng As Range, x As Long

Set rng = Range("A2:A100")
Dim cell As Range

With Range("A2:A100").SpecialCells(xlCellTypeVisible)
   For x = .Rows.Count To 1 Step -1
       Set cell = Range("A" & x) ' this sets the current cell in the loop
            For Each cl In rng.SpecialCells(xlCellTypeVisible)
                For r = LR To 2 Step -1
                    If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1 Then
                        Rows(r).Interior.Color = rgbBlueViolet
                    End If
                Next r
        Next cl
    Next x
End With
End Sub

Код выше только цвета имена, которые являются уникальными для весь документ, это Мэри Х, Анна У и Томас Y. Однако мне нужно, чтобы код включал также 3 нижеприведенных имени, которые встречаются только один раз в конкретном запросе. (Это просто пример)

7208497 Kevin M
7208497 Julia K
8138382 Shahida B

Пример данных:

Request Number  Client Contact Assignee: Full Name
4350257 Eleanor B
4350257 Eleanor B
4350257 Mary H
8620428 Kevin M
8620428 Kevin M
7208497 Michael W
7208497 Kevin M
7208497 Michael W
7208497 Julia K
7191212 Thomas Y
7191212 Shahida B
7191212 Shahida B
7191212 Shahida B
8138382 Julia K
8138382 Julia K
8138382 Shahida B
8138382 Julia K
8138382 Anna W

Answer 1

Ваш код не может делать то, о чем вы говорите. Я угадал, что вы хотите, и написал прилагаемый код для вас. Он должен быть вставлен в модуль кода вашей Sheet1 таблицы. Это процедура события, и правильное местоположение имеет решающее значение. Если он вставлен в другое место, он не будет работать.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim ReqNo As Long
    Dim Rng As Range
    Dim Cell As Range
    Dim C As Long

    ' skip if more than one cell was selected
    If Target.Cells.CountLarge = 1 Then
        Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))

        If Not Application.Intersect(Target, Rng) Is Nothing Then
            Application.ScreenUpdating = False
            ReqNo = Target.Value
            C = Cells(1, Columns.Count).End(xlToLeft).Column
            With Rng
                Set Rng = .Resize(.Rows.Count, Cells(1, Columns.Count).End(xlToLeft).Column)
            End With
            With Rng.Resize(Rng.Rows.Count, C)
                .Interior.Pattern = xlNone           ' remove existing coloring
                .Font.Color = 0
            End With

            For Each Cell In Rng
                With Cell
                    If .Value = ReqNo Then
                        .Resize(1, C).Interior.Color = rgbBlueViolet
                        .Resize(1, C).Font.Color = xlAutomatic
                    End If
                End With
            Next Cell
            Application.ScreenUpdating = True
        End If
    End If
End Sub

Найдите эту строку кода в приведенной выше процедуре. Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)). Он указывает, что Номер запроса должен быть в столбце A. Если вы переместите его в другой столбец, вы можете изменить его здесь. Аналогично, эта строка указывает, что должны рассматриваться только элементы из строки 2 и ниже. Вы можете изменить это здесь, если необходимо.

Найдите строку C = Cells(1, Columns.Count).End(xlToLeft).Column. Он указывает, что строка 1, то есть строка заголовка, - это место, где вы берете меру для ширины таблицы. Вы можете указать другую строку здесь.

Код начинает действовать, если вы нажмете Номер запроса . Все строки с тем же номером будут окрашены в фиолетовый цвет. Поскольку выбранный цвет фона темный, он изменит цвет шрифта на белый.

Надеюсь, этот код будет вам полезен.

Answer 2

Пожалуйста, попробуйте этот код. Это соответствует вашему обновленному, лучшему описанию ваших требований.

Sub DeleteNonDuplicates()

    Dim Rng As Range
    Dim Cnt As Long
    Dim R As Long

    Application.ScreenUpdating = False
    With Sheet1
        R = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, "A"), .Cells(R, "A"))
        For R = R To 2 Step -1
            Cnt = Application.WorksheetFunction.CountIfs(Rng, .Cells(R, "A").Value, _
                                                         Rng.Offset(0, 1), .Cells(R, "B").Value)
            If Cnt = 1 Then
                .Rows(R).EntireRow.Delete
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Чтобы предварительно проверить результат на вашем образце, введите формулу ниже в пустой столбец и скопируйте вниз.

=COUNTIFS($A$2:$A$19,$A2,$B$2:$B$19,$B2)

Код применяет именно эту формулу, а затем удаляет все строки, где число = 1.

Answer 3

Это не работает для видимых ячеек, потому что вы проверяете счет по всему столбцу Set rgn2 = Columns(CCFullName) вместо только видимых ячеек.

If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1

Для rgn2 также следует использовать .SpecialCells(xlCellTypeVisible). Но это не будет работать для Columns, поэтому вам придется использовать Range.

Set rgn2 = Range("B2:B19").SpecialCells(xlCellTypeVisible)