Excel - выделять и удалять повторяющиеся значения столбцов в строке

Question

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

Вот образец листа:

Мне нужно пройти через каждую строку, найти дубликаты в столбцах B:E и удалить все ячейки, кроме одной, предпочтительно сдвигая оставшиеся ячейки влево, чтобы избежать пустых ячеек. Мне нужно было бы сохранить все строки и остальные их данные в целости и сохранности.

Итак, учитывая приведенный выше пример, результат будет выглядеть так:

Пара замечаний:

• Все рассматриваемые ячейки появляются в конце каждой строки.
• Основание: Все эти значения были сохранены в виде списка в одном столбце и разделены с использованием Text to Columns . Теперь мне нужно очистить его и удалить дубликаты.
• Есть тысячи строк и пара сотен дополнительных столбцов, которые могут иметь дубликаты.

Это возможно, даже с VBA? Любые предложения с благодарностью. Спасибо!

Answer 1

Вот результаты теста скорости для опубликованных ответов (10K строк и 1K столбцов):

VBA 1 - Time:  19.488 sec - RemoveRowDupes (this answer)

VBA 2 - Time: 109.434 sec - dostuff (after turning off ScreenUpdating)

Formula test: N/A (gave up after 5 minutes filling out 10Kx1K range with array, at 9%)

---

Option Explicit
Public Sub RemoveRowDupes()
    Dim ur As Range, cc As Long, r As Range, a As Variant
    Dim s As String, i As Long, l As Long, t As Long, tt As Double, tr As String
    tt = Timer
    Set ur = Sheet1.UsedRange
    cc = ur.Columns.Count - 1
    With ur.Offset(, 1).Resize(, cc)
        Application.ScreenUpdating = False
        For Each r In .Rows
            s = Join(Application.Transpose(Application.Transpose(r)), "|")
            a = Split(s, "|"):
            l = Len(s)
            For i = 0 To cc - 1
                If Len(a(i)) > 0 Then
                    s = Replace(s, a(i), "^^")
                    s = Replace(s, "^^", a(i), , 1)
                    s = Replace(s, "^^", vbNullString)
                    If l > Len(s) Then
                        a = Split(s, "|")
                        l = Len(s)
                    End If
                End If
            Next
            s = Replace(s, "||", "|")
            If Right(s, 1) = "|" Then s = Left(s, Len(s) - 1)
            t = Len(s) - Len(Replace(s, "|", ""))
            r.ClearContents:    r.Resize(, t + 1) = Split(s, "|")
        Next
        Application.ScreenUpdating = True
    End With
    tr = "Rows: " & Format(ur.Rows.Count,"#,###") & "; Cols: " & Format(cc,"#,###") & "; "
    Debug.Print tr & "Time: " & Format(Timer - tt, "0.000") & " sec - RemoveRowDupes()"
End Sub

---

Тестовые данные:

---

Результат - RemoveRowDupes()

---

Результат - dostuff()

---

Примечание: этот ответ можно улучшить (если необходимо), используя массивы вместо взаимодействия с диапазоном

Answer 2

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

Эта формула массива, заполненная справа и вниз от B7, дает результаты, показанные ниже:

=IFERROR(INDEX($B1:$E1,,MATCH(0,COUNTIF($A7:A7,$B1:$E1),0)),"")

Обратите внимание, что это формула массива, и ее нужно вводить с помощью клавиши CTRL Shift Enter.

Учебник о том, как работает эта формула, приведен в Exceljet.

Answer 3

Если вы хотите использовать VB для обработки данных на месте, вы можете использовать следующее:

Sub dostuff()
Dim myarray As Variant
ReDim myarray(10000)

i = 0 'row iterator

Do While (Range("A1").Offset(i, 0).Value <> "")
 j = 0 'single item iterator
 k = 0 'column iterator
 m = 0 'stored array iterator
 m_max = 0 'number of unique values on the row

 'iterate single values
 Do While (Range("B1").Offset(i, j).Value <> "")
  temp = Range("B1").Offset(i, j).Value

  'compare to saved
  flag = 0
  m = 0
  Do While (m <= m_max)
   If temp = myarray(m) Then
     flag = 1
   End If
   m = m + 1
  Loop

  'add if unique
  If flag = 0 Then
   m_max = m_max + 1
   myarray(m_max) = temp
  End If

  j = j + 1
 Loop

 'clear existing
 Range("B1").Offset(i, 0).Select
 Range(Selection, Selection.End(xlToRight)).Clear

 'write saved
 m = 1
 Do While m <= m_max
  Range("B1").Offset(i, m - 1).Value = myarray(m)
  m = m + 1
 Loop

  i = i + 1
Loop
End Sub