Excel [VBA] Найти повторяющийся вопрос

Question

Я использую Excel 2010 и у меня вопрос VBA.

У меня есть некоторый код VBA, который создает уникальный ключ, а затем ищет повторяющиеся записи уникальных ключей. Любые дубликаты окрашены в красный цвет.

Что мне нужно, это немного автоматизировать это. Если есть повторяющийся уникальный ключ, я хочу, чтобы он скопировал информацию из новейшей записи и вставил ее в строку, где находится исходная запись. Затем я хочу удалить самую новую запись.

Чтобы объяснить немного дальше. Уникальный ключ - это конкат, составленный из имени клиента и даты создания файла. На каждого клиента будет приходиться не более 1 повторяющейся записи, потому что дата последнего обновления файла изменилась. Мне нужна повторяющаяся запись concat с самой новой датой, чтобы скопировать информацию поверх записи с самой старой датой, а затем удалить исходную самую новую запись даты. Это связано с тем, что у нас есть другие проверки, которые были выполнены в дальнейшем по листу, которые мы должны держать в такте.

В идеале я хотел бы, чтобы в окне сообщения все же сообщалось, сколько дубликатов было найдено и для записиостаться красным после того, как будет выполнено копирование / вставка / удаление, чтобы выделить измененную запись.

Я не могу на всю жизнь понять, как это сделать. Я довольно новичок в VBA и собрал следующее на основе таких форумов, как этот.

Пожалуйста, кто-нибудь может мне помочь? Если мой код ниже неправильный / длинный, то сообщите мне об этом тоже. Я хочу учиться.

Private Sub CommandButton1_Click()


'Start of Concatenate Code
  Dim i As Integer
  Dim r As Range
  On Error Resume Next

' Tells Excel to look in column 3 (Column C) for the last one with data in it
  lRow = Cells(Rows.Count, 3).End(xlUp).Row

' Tell Excel to focus on cells 4 to 5000
  For i = 4 To lRow
' Tell Excel to paste the contents of cell 4 (column D) followed by | then the contents of cell 8 (column H) into cell 2 (column B)
    Cells(i, 2).Value = Cells(i, 11) & " | " & Cells(i, 7)
  Next i

'End of Concatenate Code

'Start of Check for Duplicates code

  Dim j As Integer
  Dim myCell As Range
  Dim myRange As Integer

  myRange = Range("A4:A5000").Count


  j = 0
  ' Select the Range
  For Each myCell In Range("B4:B5000")
  ' Check that the cells in the range are not blank
  If WorksheetFunction.CountIf(Range("B4:B5000"), myCell.Value) > 1 Then
  ' Colour the duplicate entries in red
  myCell.EntireRow.Interior.ColorIndex = 3


  j = j + 1

  End If
Next

  MsgBox "There are " & j & " duplicates found." & vbCrLf & vbCrLf & "Any duplicates have been highlighted in red.", vbInformation + vbOKOnly, "Duplicate Entry Checker"

' End of Check for Duplicates code


End Sub

Заранее благодарю,

Крейг

** РЕДАКТИРОВАНИЕ, ЧТОБЫ ВКЛЮЧИТЬ СКРИНШОТ РАСПИСАНИЯ ДЛЯ @rickmanalexander ** Электронная таблицаСкриншот

Answer 1

Спасибо @rickmanalexander, я только что попробовал ваш код (и изменил название листа), но у меня появляется ошибка, выходящая за пределы диапазона, с номером 9 в заголовке msgbox. Там должно быть что-то, что я пропустил, но я не уверен, что?

Вот код, который я использовал:

Private Sub CommandButton1_Click()

    On Error GoTo CleanFail
    Dim wrkSht As Worksheet
    Set wrkSht = Sheets("Raw Data")

    Dim lRow As Long
    lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row

    Dim arrySheet As Variant
    'get the worksheet data into an array
    arrySheet = wrkSht.Range("D1:H" & lRow).Value2

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim keyValue As Variant
    Dim i As Long
    Dim rowNum As Long
    Dim dupCount As Long

    For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)

        'a concatenated key consisting of the:
        'row number
        'customer's name
        keyValue = Join(Array(i, arrySheet(i, 1)), "|")

        If Not dict.Exists(keyValue) Then
            dict(keyValue) = arrySheet(i, 8) 'save the date for this unique key

        Else
            'if we make it here, then this is a duplicate customer
            'for which we want to check the date

            'If the current row's date is greater than the previouly saved date, then
            'delete the current row
            'determine the row umber for the previously saved entry
            'place the most recent date in place of the old date
            'color it red
            'increase the duplicate counter
            If arrySheet(i, 8) > dict(keyValue) Then

                wrkSht.Rows(i).EntireRow.Delete

                rowNum = CLng(Split(keyValue, "|")(0))

                wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 8))

                wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3

                dupCount = dupCount = dupCount + 1
            End If
        End If

       'clear variables
       keyValue = vbNullString: rowNum = 0
    Next i


  MsgBox "There were " & dupCount & " duplicates found." & _
        vbCrLf & vbCrLf & _
        "Any duplicates have been highlighted in red.", _
        vbInformation + vbOKOnly, "Duplicate Entry Checker"

CleanExit:
    Exit Sub


CleanFail:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume CleanExit


End Sub

Answer 2

Редактировать: ОП получал Error 9 subscript out of range, потому что я использовал arrySheet(i, 8) вместо arrySheet(i, 4). Я думал, что я определил массив из диапазона, начиная с столбца А. Простая ошибка с легким исправлением.

Объект Dictionary является идеальным кандидатом для повторных проверок, так что это то, с чем я столкнулся. Код ниже не протестирован, но должен работать для ваших нужд.

Option Explicit

Private Sub CommandButton1_Click()

    On Error GoTo CleanFail
    Dim wrkSht As Worksheet
    Set wrkSht = Sheets("Raw Data")

    Dim lRow As Long
    lRow = wrkSht.Cells(wrkSht.Rows.Count, 3).End(xlUp).Row

    Dim arrySheet As Variant
    'get the worksheet data into an array
    arrySheet = wrkSht.Range("D1:H" & lRow).Value2

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim keyValue As Variant
    Dim i As Long
    Dim rowNum As Long
    Dim dupCount As Long

    For i = LBound(arrySheet, 1) To UBound(arrySheet, 1)

        'a concatenated key consisting of the:
        'row number
        'customer's name
        keyValue = Join(Array(i, arrySheet(i, 1)), "|")

        If Not dict.Exists(keyValue) Then
            dict(keyValue) = arrySheet(i, 4) 'save the date for this unique key

        Else
            'if we make it here, then this is a duplicate customer
            'for which we want to check the date

            'If the current row's date is greater than the previouly saved date, then
            'delete the current row
            'determine the row umber for the previously saved entry
            'place the most recent date in place of the old date
            'color it red
            'increase the duplicate counter
            If arrySheet(i,4) > dict(keyValue) Then

                wrkSht.Rows(i).EntireRow.Delete

                rowNum = CLng(Split(keyValue, "|")(0))

                wrkSht.Cells(rowNum, "B").Value = CDate(arrySheet(i, 4))

                wrkSht.Rows(rowNum).EntireRow.Interior.ColorIndex = 3

                dupCount = dupCount = dupCount + 1
            End If
        End If

       'clear variables
       keyValue = vbNullString: rowNum = 0
    Next i


  MsgBox "There were " & dupCount & " duplicates found." & _
        vbCrLf & vbCrLf & _
        "Any duplicates have been highlighted in red.", _
        vbInformation + vbOKOnly, "Duplicate Entry Checker"

CleanExit:
    Exit Sub


CleanFail:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume CleanExit


End Sub