ListView Изменение цвета дубликатов подпунктов

Question

Если у меня заполнен вид списка, как бы я изменил цвет шрифта, если в этом столбце уже есть подпункт?

Любая помощь будет принята.

Этоэто то, что у меня есть, но оно не работает правильно

Sub dupeInterpreters(lvw As ListView, iSubItemIndex As Integer)
    Dim i As Integer
    Dim dupeI As Integer

    dupeI = 0

    For i = 1 To LVIV.ListItems.Count

        If LVIV.ListItems(i).SubItems(iSubItemIndex) = LVIV.ListItems(i).ListSubItems(iSubItemIndex).Text Then 'you could also use the LIKE operator
            'LVIV.ListItems(i).Selected = True
            LVIV.ListItems(i).Bold = True
            LVIV.ListItems(i).ListSubItems(iSubItemIndex).ForeColor = &HC000&
            dupeI = dupeI + 1
            'Exit For
        End If

    Next

End Sub

Нет ошибок, но оно выделяет каждый элемент в списке, а не только повторяющиеся значения

Answer 1

Вот другой подход. Этот использует объект Dictionary, чтобы избежать чрезмерного зацикливания, и должен быть более эффективным ...

Sub dupeInterpreters(LVIV As ListView, iSubItemIndex As Integer)

    Dim dicListSubItemCount As Object
    Dim strListSubItem As String
    Dim listItemIndex As Long

    Set dicListSubItemCount = CreateObject("Scripting.Dictionary")
    dicListSubItemCount.comparemode = 1 'case-insensitive comparison

    With LVIV
        For listItemIndex = 1 To .ListItems.Count
            strListSubItem = .ListItems(listItemIndex).ListSubItems(iSubItemIndex).Text
            dicListSubItemCount(strListSubItem) = dicListSubItemCount(strListSubItem) + 1
        Next listItemIndex
        For listItemIndex = 1 To .ListItems.Count
            strListSubItem = .ListItems(listItemIndex).ListSubItems(iSubItemIndex).Text
            If dicListSubItemCount(strListSubItem) > 1 Then
                With .ListItems(listItemIndex)
                    .Bold = True
                    .ListSubItems(iSubItemIndex).ForeColor = &HC000&
                End With
            End If
        Next listItemIndex
    End With

    Me.Repaint

    Set dicListSubItemCount = Nothing

End Sub

Надеюсь, это поможет!

Answer 2

Попробуйте следующий макрос, который форматирует все дубликаты ...

Sub dupeInterpreters(LVIV As ListView, iSubItemIndex As Integer)

    Dim i As Long
    Dim j As Long
    Dim bDuplicate As Boolean

    bDuplicate = False
    For i = 1 To LVIV.ListItems.Count - 1
        For j = i + 1 To LVIV.ListItems.Count
            If LVIV.ListItems(j).SubItems(iSubItemIndex) = LVIV.ListItems(i).ListSubItems(iSubItemIndex).Text Then
                'LVIV.ListItems(i).Selected = True
                LVIV.ListItems(j).Bold = True
                LVIV.ListItems(j).ListSubItems(iSubItemIndex).ForeColor = &HC000&
                bDuplicate = True
            End If
        Next j
        If bDuplicate Then
            With LVIV.ListItems(i)
                .Bold = True
                .ListSubItems(iSubItemIndex).ForeColor = &HC000&
            End With
            bDuplicate = False
        End If
    Next

    Me.Repaint

End Sub

Надеюсь, это поможет!