excel - 如何在 excel vba 中查找和评论大数据的重复项？

Question

我有一个代码可以根据第一列查找和突出显示(整行)重复项。现在我正在尝试复制最后找到的评论并将其粘贴到找到的副本:



在此示例中，应将第 8 行中的注释“Controle 1:OK”复制并粘贴到第 10 行。
但是对于我的代码，总是复制第一个注释“Controle 1:NOK”并将注释粘贴到第 8 行和第 10 行。

我是 Excel VBA 的新手，只是有一个线索(将所有找到的评论放在一个数组中并取最后一条评论)但不知道如何实现它。

有人知道如何做到这一点吗？

我正在使用 Excel 365。

 Sub sbFindDuplicatesInColumn()

    Dim lastRow As Long             
    Dim matchFoundIndex As Long
    Dim iCntr As Long               
    Dim comment As String

    lastRow = Range("A65000").End(xlUp).Row

    For iCntr = 1 To lastRow
    If Cells(iCntr, 1) <> "" Then
        matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
        comment = Cells(matchFoundIndex, 3).Value
        If iCntr <> matchFoundIndex Then

             Cells(iCntr, 3).Value = comment
             Range(Cells(iCntr, 1), Cells(iCntr, 3)).Font.Color = RGB(255, 40, 0)

       End If
    End If

    Next
End Sub

Answer 1

也许是这样的。
它应该循环所有行并在“A”列中查找重复项。如果发现重复并且在重复行中没有评论，则复制最后一个已知评论。
如果找到重复但已经有评论，则此评论将成为新的“最后已知”以供进一步重复。

Option Explicit

Sub Dupes()

Dim Ws As Worksheet
Dim LastRow As Long, i As Long, j As Long, DupCounter As Long, DupPos As Long
Dim MatNo As String, Comment As String
Dim Found As Boolean
Dim ArrDuplicates() As Variant 'Declare dynamic array 

Set Ws = ThisWorkbook.Sheets(1)

'Redimennsion/change size of declared array 
ReDim ArrDuplicates(1 To 2, 1 To 1)

DupCounter = 1

With Ws
    'find last row with data in column "A" 
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    'Loop all rows from 1 to last 
    For i = 1 To LastRow
        'reset variables for each loop 
        Found = False
        DupPos = 0
        MatNo = .Cells(i, 1)
        Comment = .Cells(i, 3) 'Column 3 is column "C" if other 
                              'column to be used just change the number 
        'Search array with previous data and look for duplicates 
        For j = LBound(ArrDuplicates(), 2) To UBound(ArrDuplicates(), 2)
           'If material number currently checked found in array 
            If MatNo = ArrDuplicates(1, j) Then
                'If comment for current row is empty, take comment from array 
                If Trim(Comment) = "" Then
                    Comment = ArrDuplicates(2, j)
                End If
                'remember position of source data in array (first occurence
                'of material number)
                DupPos = j
                'set "Found" marker 
                Found = True
                'leave loop 
                Exit For
            End If
        Next j

        'if no duplicate found 
        If Not Found Then
            'redimension array. "Preserve" keyword added to keep values
            'already existing in array
            ReDim Preserve ArrDuplicates(1 To 2, 1 To DupCounter)
            'insert new data to array ((first occurance of material number) 
            ArrDuplicates(1, DupCounter) = MatNo
            ArrDuplicates(2, DupCounter) = Comment
            DupCounter = DupCounter + 1 'increase counter used to redimension array 
        Else  'if material number found in array 
            'if commnet variable is same as comment in array 
            'This means that comment of current row was empty  
            If Comment = ArrDuplicates(2, DupPos) Then
                .Cells(i, 3) = Comment 'put comment in current row and column 3 "C"
            Else
                'Commnet in current row was not empty and different than last one 
                'replace "last known comment" in array for material number 
                'with new one from current row 
                ArrDuplicates(2, DupPos) = Comment
            End If
            'change font colour 
            .Cells(i, 3).Font.Color = vbRed
        End If
    Next i
End With

End Sub

编辑:添加了一些评论

Check also ReDim Statement