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

如果您想使用 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

Answer 3

您可以使用公式来执行此操作，但正确的值将位于不同的位置，至少暂时如此。要将数据保留在同一位置，您可以复制新数据，然后使用“选择性粘贴”>“值”覆盖旧数据。

此数组公式从 B7 向右向下填充，结果如下所示：

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

请注意，这是一个数组公式，必须用 输入CTRLShiftEnter。

有关此公式如何工作的教程位于捷捷。