L oop через строки данных и цвета с запросами, которые содержат только одно имя - PullRequest
Новая
       3

L oop через строки данных и цвета с запросами, которые содержат только одно имя

0 голосов
/ 03 марта 2020

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

Мой код [ОБНОВЛЕНО] 

    Private Function NameInList(searchName As String, MyArray As Variant) As Boolean

MyArray = Range("B1:B50")
    Dim found As Boolean: found = False
    Dim name As Variant
    For Each name In MyArray
        If name = searchName Then
            found = True
            Exit For
        End If
    Next name
    NameInList = found
End Function



Sub DeleteRows2()

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)

'delete if CounIf = 1

For r = LR To 2 Step -1
    If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1 Or NameInList(Cells(r, CCFullName).Value) = True Then
    Rows(r).Interior.Color = rgbBlueViolet
'    Rows(r).Delete
    End If

Next r



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

1 Ответ

0 голосов
/ 03 марта 2020

Как насчет добавления функции, которая проверяет, соответствует ли имя дополнительным элементам, которые вы упомянули, и добавлению условия OR к вашему для l oop?

[Новая функция] 

Private Function NameInList(searchName as String, ArrayOfNames as Variant) as Boolean
    Dim found As Boolean: found = False
    Dim name As Variant
    For Each name In ArrayOfNames
        If name = searchName Then
            found = True
            Exit For
        End If
    Next name
    NameInList = found
End Function

А затем в исходном Для L oop просто измените эту строку If Application.WorksheetFunction.CountIf(rgn2, Cells(r, CCFullName).Value) = 1 на следующую: 

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