Блог

У меня есть лист с данными в 2 столбцах, A и B:

 --A--     --B--
Apple     57
Orange    62
Lime      45
Orange    58
Apple     57
Orange    78
Lime      23
Melon     15
  

Мне нужно выполнить поиск дубликатов в столбце A, затем, если они есть, найдите их значение в столбце B. Если они разные, я хочу покрасить ячейку в столбце A в красный цвет, показать другое значение этой записи в столбце C и показать сообщение о том, сколько существует безразличий. Если в столбце A более 2 записей, а в столбце B — несколько разных значений, тогда я хочу показать другие значения в столбцах C, D, E и т. Д. Что-то вроде этого:

 --A--     --B--   --C--   --D--
 Apple     57
 Orange    62       58     78
 Lime      45       23
 Orange    58       62     78
 Apple     57
 Orange    78       58     62
 Lime      23       45
 Melon     15
  

У меня есть код, который почти делает это, что означает, что он показывает различия в столбце C, если в столбце A. Есть только два одинаковых значения. Однако, если в столбце A более 2 одинаковых значений, то он дает неполные данные для столбцов C, D и т. Д. Вот так:

 --A--     --B--   --C--
 Apple     57
 Orange    62       58  
 Lime      45       23
 Orange    58       78 
 Apple     57
 Orange    78       62 
 Lime      23       45
 Melon     15
  

Вот код:

 Dim pos As Variant 'match index
Dim rows As Integer
Dim i As Variant
Sheets("Chain").Range("C1:C1000").ClearContents
rows = Range("A:A").End(xlDown).Row 'Getting total row number
For i = 1 To rows

    'Find position of next occurence
    If i = 1 Then
    pos = WorksheetFunction.Match(Range("A" amp; i).Value, Range("A" amp; i amp; ":A" amp; rows   1), 0)   i
    Else
    pos = WorksheetFunction.Match(Range("A" amp; i).Value, Range("A" amp; i   1 amp; ":A" amp; rows   1), 0)   i
    End If
    'If there is no next occurence find previous occurences
    If pos = 0 Then
    pos = WorksheetFunction.Match(Range("A" amp; i).Value, Range("A1:A" amp; i - 1), 0)

    End If

    On Error Resume Next

    Dim j As Integer
    Dim pos1 As Integer
    Dim pos2 As Integer
    j = i

    'While next occurence is same skip it
    While (Cells(i, 2) = Cells(pos, 2)) And (j < rows)
        j = 1   pos
        pos1 = pos
        pos = WorksheetFunction.Match(Range("A" amp; i).Value, Range("A" amp; j amp; ":A" amp; rows   1), 0)   j - 1
        pos2 = pos
        If pos1 = pos2 Then GoTo Endwhile

    Wend
Endwhile:

    'Writing into Column C
    Range("C" amp; i).Value = Cells(pos, 2).Value
    ' Highlighting duplicate cells
    If Cells(i, 2) <> Cells(i, 3) Then

    Range("A" amp; i).Interior.Color = TextBox5.BackColor
    End If

    If Cells(i, 2) = Cells(i, 3) Then Cells(i, 3) = ""
    pos = 0

Next i

'Final Message

Dim totdif As Integer
totdif = WorksheetFunction.CountA(Range("C1:C1" amp; rows))
If totdif = 0 Then
MsgBox "No indifferences found"
Else
MsgBox "Indifferences found: " amp; totdif
End If
  

У меня возникнет соблазн сделать это таким образом, используя словарь для сбора уникальных значений:

 Sub Tester()

    Dim dict As Object, rng As Range, rw As Range, tmp, u As Long, vA, vB, e, n
    
    Set dict = CreateObject("scripting.dictionary")
    Set rng = ActiveSheet.Range("A1", Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
    rng.Offset(0, 2).Resize(, 50).ClearContents 'clear any previous results
    
    'first collect all ColB values for each unique colA value
    For Each rw In rng.Rows
        vA = rw.Cells(1).Value
        vB = rw.Cells(2).Value
        If Not dict.exists(vA) Then
            dict.Add vA, Array(vB) 'new key
        Else
            tmp = dict(vA)
            'already have this value for this key?
            If IsError(Application.Match(vB, tmp, 0)) Then
                u = UBound(tmp)   1
                ReDim Preserve tmp(u)
                tmp(u) = vB 'add the new value
                dict(vA) = tmp
            End If
        End If
    Next rw
    
    'loop the rows again and add all the values
    For Each rw In rng.Rows
        vA = rw.Cells(1).Value
        vB = rw.Cells(2).Value
        
        tmp = dict(vA)
        'have >1 value ?
        If UBound(tmp) > 0 Then
            rw.Cells(1).Font.Color = vbRed
            n = n   1
            For Each e In tmp
                'add if doesn't match the existing value on this row
                If e <> vB Then Cells(rw.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = e
            Next e
        End If
    Next rw
    MsgBox n amp; " duplicates" 
End Sub