Извлечение уникальных значений в последнюю таблицу в VBA

Question

У меня есть таблица (Sheet2) со списком уникальных идентификаторов проектов, этот список основан на расширенном фильтре и регулярно обновляется, добавляя новые проекты, в то время как многие старые проекты все еще появляются в списке.

У меня есть другая таблица (Sheet1), где уникальные проекты (которые существуют в таблице A, но отсутствуют в таблице B) должны быть скопированы в последнюю строку (+1) таблицы. Затем пользователи будут вводить информацию о проектах, поэтому важно, чтобы информация, уже находящаяся в таблице, не изменялась при загрузке новых проектов.

У меня есть этот код, и на поверхности он делает свою работу. Но я думаю, что это может быть немного неуклюжим, и пользователи столкнулись с тем, что при запуске макроса в таблицу B иногда добавляются дубликаты. Из кода я не вижу, как это возможно, и я не смог повторить это.

Может кто-нибудь взглянуть на код и посмотреть, есть ли проблема? Или подумать о более простом способе сделать то, что я ищу? Я новичок в VBA, и код, который я написал, был поднят и адаптирован из других мест методом проб и ошибок, поэтому мне сложно понять, что с ним не так :-)

Идентификаторы проекта находятся в столбце A, и я пытаюсь скопировать значения A: D из Sheet2 в Sheet1

Option Explicit

Public Sub Projecs()

   Dim Source As Long
   Dim Dest As Long
   Dim Count As Long

   Source = 1
   Dest = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row

   Do Until Sheet2.Cells(Source, "A") = ""
      If Sheet1.Range("A:A").Find(what:=Sheet2.Cells(Source, "A"), lookat:=xlWhole) Is Nothing Then
         Dest = Dest + 1
         Sheet1.Range(Sheet1.Cells(Dest, "A"), Sheet1.Cells(Dest, "D")).Value = _
            Sheet2.Range(Sheet2.Cells(Source, "A"), Sheet2.Cells(Source, "D")).Value
         Count = Count + 1
      End If
      Source = Source + 1
   Loop

   MsgBox "Copied " & Count & " projects to production"

End Sub

Спасибо за вашу помощь!

Answer 1

Резервное копирование

При необходимости измените значения в разделе констант, например, если у вас есть заголовок или заголовки в первой строке, тогда вам не нужно l oop через эти ячейки.

Аргумент After в Find - это просто начать поиск с первой ячейки в столбце. Это может быть опущено. Внимательно изучите другие аргументы Find, потому что они могут пригодиться в будущем.

Сделайте несколько комментариев, или через некоторое время вам будет очень трудно понять код.

Option Explicit

Public Sub Projecs()

   Const rowSrc As Long = 1   ' Source First Row Number
   Const rowTgt As Long = 1   ' Target First Row Number
   Const colSrc As Long = 1   ' Source Compare Column Number
   Const colTgt As Long = 1   ' Target Compare Column Number
   Const NoC As Long = 4      ' Number of Copy Columns


   Dim wsSrc As Worksheet     ' Source Worksheet
   Dim wsTgt As Worksheet     ' Target Worksheet
   Dim rngTgt As Range        ' Target Column Range
   Dim lrSrc As Long          ' Source Last Non-Empty Row
   Dim lrTgt As Long          ' Target Last Non-Empty Row,
                              ' Target First Empty Row After Last Non-Empty Row
   Dim i As Long              ' Source Rows Counter
   Dim Count As Long          ' Copied Projects Counter

   ' Beware, you are using CodeNames, not the names in the TABS.
   ' Which is great. Now you can change the names in the Tabs and
   ' the code will still run perfectly.
   Set wsSrc = Sheet2
   Set wsTgt = Sheet1

'   ' This might work ...
'   wsTgt.AutoFilterMode = False
'   ' Calculate Last Non-Empty Row in both Worksheets.
'   lrSrc = wsSrc.Cells(wsSrc.Rows.Count, colSrc).End(xlUp).Row
'   lrTgt = wsTgt.Cells(wsTgt.Rows.Count, colTgt).End(xlUp).Row

   ' ... but better is:
   ' Calculate Last Non-Empty Row in both Worksheets.
   lrSrc = _
     wsSrc.Columns(colSrc).Find(What:="*", SearchDirection:=xlPrevious).Row
   lrTgt = _
     wsTgt.Columns(colTgt).Find(What:="*", SearchDirection:=xlPrevious).Row

   ' Lesson: You better always use the Find method to calculate the Last
   ' Non-Empty Row especially when there is autofilter envolved where
   ' it becomes a MUST.

   ' Define Target Column Range.
   Set rngTgt = wsTgt.Cells(rowTgt, colTgt).Resize(lrTgt - rowTgt + 1)

   ' Loop through cells in Compare Column of Source Worksheet.
   For i = rowSrc To lrSrc
       ' Check if current cell of Source Worksheet can NOT be found
       ' in Target Column Range.
       If rngTgt.Find(What:=wsSrc.Cells(i, colSrc), After:=rngTgt _
         .Cells(rngTgt.Rows.Count, 1), LookAt:=xlWhole) Is Nothing Then
           ' Add current project to the count.
           Count = Count + 1
           ' Calculate Target First Empty Row After Last Non-Empty Row.
           lrTgt = lrTgt + 1
           ' Write values from Source Row Range to Target Row Range.
           wsTgt.Cells(lrTgt, colTgt).Resize(, NoC).Value = _
             wsSrc.Cells(i, colSrc).Resize(, NoC).Value
       End If
   Next

   MsgBox "Copied " & Count & " projects to production"

End Sub

РЕДАКТИРОВАТЬ 1:

Вот версия ячейка за ячейкой. Он работает нормально (больше не добавляет дубликатов), но проблема «крошечного» автофильтра по-прежнему сохраняется.

РЕДАКТИРОВАТЬ 2:

Я добавил строку кода, исправляющую проблему «крошечного» автофильтра в Target Рабочий лист прямо перед MsgBox. Ранее, когда значения в Target Worksheet были отфильтрованы (номера строк были синего цвета), тогда новые добавленные значения (строки) не были отфильтрованы (номера строк были черными). Я переписываю, потому что добавлена ​​только одна строка значимости.

Option Explicit

Public Sub Projecs()

   Const rowSrc As Long = 1   ' Source First Row Number
   Const rowTgt As Long = 1   ' Target First Row Number
   Const colSrc As Long = 1   ' Source Compare Column Number
   Const colTgt As Long = 1   ' Target Compare Column Number
   Const NoC As Long = 4      ' Number of Copy Columns


   Dim wsSrc As Worksheet     ' Source Worksheet
   Dim wsTgt As Worksheet     ' Target Worksheet
   Dim rngTgt As Range        ' Target Column Range
   Dim lrSrc As Long          ' Source Last Non-Empty Row
   Dim lrTgt As Long          ' Target Last Non-Empty Row,
   Dim frTgt As Long          ' Target Empty Row After Last Non-Empty Row
   Dim i As Long              ' Source Rows Counter
   Dim j As Long              ' Target Rows Counter
   Dim Count As Long          ' Copied Projects Counter

   ' Beware, you are using CodeNames, not the names in the TABS.
   ' Which is great. Now you can change the names in the Tabs and
   ' the code will still run perfectly.
   Set wsSrc = Sheet2
   Set wsTgt = Sheet1

   ' Calculate Last Non-Empty Row in both Worksheets.
   lrSrc = _
     wsSrc.Columns(colSrc).Find(What:="*", SearchDirection:=xlPrevious).Row
   lrTgt = _
     wsTgt.Columns(colTgt).Find(What:="*", SearchDirection:=xlPrevious).Row
   ' Lesson: You better always use the Find method to calculate the Last
   ' Non-Empty Row, but especially when there are autofilter or hidden rows
   ' envolved, when it becomes a MUST.

   ' Define Target Column Range.
   Set rngTgt = wsTgt.Cells(rowTgt, colTgt).Resize(lrTgt - rowTgt + 1)

   ' Calculate Target Empty Row After Last Non-Empty Row.
   frTgt = lrTgt
   ' Loop through cells in Compare Column of Source Worksheet.
   For i = rowSrc To lrSrc
       ' Loop through cells in Compare Column of Target Worksheet.
       For j = rowTgt To lrTgt
           ' Check current cell in Source Column against current cell
           ' in Target Column. If they are equal then exit the loop.
           If wsSrc.Cells(i, colSrc) = wsTgt.Cells(j, colTgt) Then Exit For
       Next
       ' When a for loop finishes without exiting, the value of the counter
       ' is by one greater than the last element i.e. Target Rows Counter (j)
       ' is equal to Target Last Non-Empty Row increased by one (1).
       ' Check Target Rows Counter against Target Last Non-Empty Row.
       If j > lrTgt Then
           ' Add current project to the count.
           Count = Count + 1
           ' Calculate Target First Empty Row After Last Non-Empty Row.
           frTgt = frTgt + 1
           ' Write values from Source Row Range to Target Row Range.
           wsTgt.Cells(frTgt, colTgt).Resize(, NoC).Value = _
             wsSrc.Cells(i, colSrc).Resize(, NoC).Value
       End If
   Next

   ' If data in Target Worksheet is filtered, then include
   ' the newly added values (rows) in the filter.
   If wsTgt.AutoFilterMode Then wsTgt.AutoFilter.ApplyFilter

   MsgBox "Copied " & Count & " projects to production"

End Sub