Как я могу предотвратить создание дубликатов

Question

Я создал таблицу Excel, которая будет отслеживать поврежденные активы, которые были отправлены обратно от наших внешних агентов. У меня есть две вкладки, которые будут в центре внимания этой таблицы. Вкладка 1 - это вкладка проверенных активов, а вкладка 2 ожидает тестирования. Поэтому, как только какой-либо актив, который будет отправлен обратно, будет вручную зарегистрирован на ожидающей вкладке тестирования, но как только он будет протестирован, я создал код vba, который будет экспортировать все, что было помечено знаком «Y», что означает, что оно было протестировано на тестируемом вкладки «активы».

Но проблема заключается в том, что один объект может быть использован для тестирования и отправлен обратно на поле нашим инженерам более одного раза, поэтому, если он снова будет протестирован и будет зарегистрирован в ожидании тестирования и как только он будет протестирован и экспортирован на вкладку проверенных активов, он дублирует то, что уже есть на вкладке проверенных активов, и я получаю две ячейки с одинаковыми данными. В любом случае, я могу добавить другую строку кода, которая подскажет мне дубликат перед его экспортом. См. Код ниже;

Sub automove() 

Dim SerialNo As String 
Dim AwaitTestLastRow, PasteToRow As Long 

Sheets("Awaiting Testing").Select 

AwaitTestLastRow = Range("a1000000").End(xlUp).Row 

For x = AwaitTestLastRow To 3 Step -1 

    If Range("c" & x).Value = "Y" Or Range("c" & x).Value = "y" Then 

     SerialNo = Range("a" & x).Value 
     Rows(x).Delete 

     Sheets("Tested Assets").Select 

     Range("a1000000").End(xlUp).Offset(1, 0).Value = SerialNo 
     Range("e1000000").End(xlUp).Offset(1, 0).Value = SerialNo 

     PasteToRow = Range("a1000000").End(xlUp).Row 

     Range("b3:d3").Select 
     Selection.Copy 
     Range("b" & PasteToRow & ":d" & PasteToRow).Select 

     ActiveSheet.Paste 

     Range("f3").Select 
     Selection.Copy 
     Range("f" & PasteToRow & ":f" & PasteToRow).Select 

     ActiveSheet.Paste 

     Sheets("Awaiting Testing").Select 

    End If 

Next x 

Answer 1

Существует много разных способов проверки дубликатов. В приведенном ниже коде я использовал функцию .Find на листе «Проверенные активы». Если возвращаемый объект равен Nothing, то это новый элемент, если это Range, тогда мы знаем адрес вашего дубликата. Это не обязательно самый быстрый способ (например, Collection), но функция .Find по-прежнему довольно быстро, и, как вы увидите в следующем комментарии, я хотел иметь адрес диапазона.

Я поставил ниже код вместо того, чтобы запрашивать дубликат, записывает частоту, с которой тот же элемент возвращается в тестовую лабораторию, может быть вам полезен для отслеживания повторного правонарушителя. Однако, если вы этого не хотите, удалите 4 строки и замените их на MsgBox asset(1, 1) & " is a duplicate."

Я немного скорректировал ваш код, чтобы ускорить его, и не забудьте указать две переменные в той же строке, что и каждая переменная должна иметь его собственный тип объявления. В вашей строке: Dim AwaitTestLastRow, PasteToRow As Long, переменная AwaitTestLastRow не является Long (она фактически не напечатана, т.е. Variant).

Sub AutoMove_v2() 
    Dim awaitingRange As Range 
    Dim testedRange As Range 
    Dim flaggedRange As Range 
    Dim newRow As Range 
    Dim dupCell As Range 
    Dim testFlag As String 
    Dim asset As Variant 
    Dim cell As Range 
    Dim frq As Long 

    'Initialise the parameters 
    With ThisWorkbook.Worksheets("Awaiting Testing") 
     Set awaitingRange = .Range("A3", _ 
          .Cells(.Rows.Count, "A").End(xlUp)) 
    End With 
    With ThisWorkbook.Worksheets("Tested Assets") 
     Set testedRange = .Range("A1", _ 
          .Cells(.Rows.Count, "A").End(xlUp)) 
    End With 

    'Loop through the awaiting sheet to find assets for transferral 
    For Each cell In awaitingRange 
     testFlag = UCase(cell.Offset(, 2).value) 
     If testFlag = "Y" Then 
      If flaggedRange Is Nothing Then 
       Set flaggedRange = cell 
      Else 
       Set flaggedRange = Union(flaggedRange, cell) 
      End If 
     End If 
    Next 

    'Identify duplicates or transfer new assets 
    For Each cell In flaggedRange 
     asset = cell.Resize(, 4).value 
     Set dupCell = testedRange.Cells.Find(What:=asset(1, 1), _ 
              After:=testedRange.Cells(1), _ 
              LookIn:=xlFormulas, _ 
              LookAt:=xlWhole, _ 
              SearchOrder:=xlByRows, _ 
              SearchDirection:=xlNext, _ 
              MatchCase:=True) 

     If dupCell Is Nothing Then 
      'It's a new entry so transfer the values 
      Set newRow = testedRange.Cells(testedRange.Cells.Count).Offset(1) 
      Set testedRange = Union(testedRange, newRow) 
      newRow.Resize(, 4) = asset 
     Else 
      'It's a duplicate so increment the frequency counter 
      frq = dupCell.Offset(, 5).value 
      If frq = 0 Then frq = 1 
      frq = frq + 1 
      dupCell.Offset(, 5) = frq 
     End If 
    Next 

    'Delete the transferred rows 
    flaggedRange.EntireRow.Delete 
End Sub