Как я могу найти и прокомментировать дубликаты для больших данных в Excel VBA?

Question

У меня есть код для поиска и выделения дубликатов (всей строки) на основе первого столбца.Теперь я пытаюсь скопировать последний найденный комментарий и вставить его в найденный дубликат:

В этом примере комментарий "Controle 1: OK" в строке 8 долженскопировать и вставить в строку 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

Может быть, что-то вроде этого.
Следует зациклить все строки и найти дубликаты в столбце «А».Если найден дубликат, а в строке с дублированием нет комментариев, копируется последний известный комментарий.
Если дубликат найден, но уже есть комментарий, этот комментарий становится новым «последним известным» для дальнейших дубликатов.

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

Редактировать: Добавлено несколько комментариев

Проверить также ReDim Statement

Answer 2

Упрощение ввода для этого:

это то, что вы получите, используя код ниже:

Option Explicit

Sub TestMe()

    Dim wks As Worksheet: Set wks = Worksheets(1)
    Dim myLastRow As Long: myLastRow = lastRow(wks.Name)
    Dim matchRow As Long

    Dim myRow As Long
    For myRow = 1 To myLastRow
        With wks
            If .Cells(myRow, 1) <> "" Then
                matchRow = WorksheetFunction.Match(.Cells(myRow, 1), .Range("A1:A" & myLastRow), 0)
                If myRow <> matchRow Then
                    .Cells(myRow, 2) = .Cells(matchRow, 2)
                    .Cells(myRow, 2).Interior.Color = vbRed
                End If
            End If
        End With
    Next myRow

    Debug.Print myLastRow

End Sub

Function lastRow(wsName As String, Optional columnToCheck As Long = 1) As Long

    Dim ws As Worksheet
    Set ws = Worksheets(wsName)
    lastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row

End Function

Он проверяет наличие дубликатов в столбце A и при обнаружении дубликата, если это не первый дубликат, получает комментарий к первому.Это проверка, является ли это первым дубликатом - If myRow <> matchRow Then