0

我在 Excel 中创建了一个宏来合并重复的行：

这个想法是，如果 2 行或更多行具有相同的 ABC 列，我会合并它们的 D 列以删除 ABC 重复项。我需要这样做，但要检查更多的列。

我的宏看起来像这样：

processingRow = 2
Do Until Cells(processingRow, 1).Value = ""
    i = processingRow + 1

    Do Until Cells(i, 1).Value = ""
       If Cells(processingRow, 8) = Cells(i, 8) And _
          Cells(processingRow, 12) = Cells(i, 12) And _
          Cells(processingRow, 7) = Cells(i, 7) And _
          Cells(processingRow, 6) = Cells(i, 6) And _
          Cells(processingRow, 5) = Cells(i, 5) And _
          Cells(processingRow, 4) = Cells(i, 4) And _
          Cells(processingRow, 3) = Cells(i, 3) And _
          Cells(processingRow, 2) = Cells(i, 2) And _
          Cells(processingRow, 1) = Cells(i, 1) Then
               If Cells(i, 14) <> "" Then
                    Cells(processingRow, 14) = Cells(processingRow, 14) & "," & Cells(i, 14)
               End If
               Rows(i).Delete


        End If
        i = i + 1
    Loop

    processingRow = processingRow + 1

Loop

当运行 500 行的宏时，它需要一段时间，但它仍然是合理的。但是我需要在超过 2500 行的 excel 中运行这个宏，而且它需要很长时间，以至于它不再实用了。

这是我在 Excel 中使用 VBA 的第一个宏，所以我想知道是否有更快的方法来处理行/单元格，因为单独访问它们似乎非常慢。

有任何想法吗？

4

1 回答 1

1

编辑：我错过了你没有检查每一列以确定什么是重复的。现在应该更近了：

Sub Tester()

Dim rngCheck As Range, rw As Range
Dim dict As Object, k As String, rwDup As Range
Dim rngDel As Range, tmp

    Set dict = CreateObject("scripting.dictionary")

    With ActiveSheet
        Set rngCheck = .Range(.Cells(2, 1), _
                              .Cells(Rows.Count, 1).End(xlUp)).Resize(, 14)
    End With

    For Each rw In rngCheck.Rows

        k = RowKey(rw)
        If dict.exists(k) Then
            Set rwDup = dict(k)
            tmp = rw.Cells(14).Value
            If Len(tmp) > 0 Then
                rwDup.Cells(14).Value = rwDup.Cells(14).Value & "," & tmp
            End If
            If rngDel Is Nothing Then
                Set rngDel = rw
            Else
                Set rngDel = Application.Union(rngDel, rw)
            End If
        Else
            dict.Add k, rw
        End If

    Next rw

    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

'create a "key" for the row by joining all columns to be checked
Function RowKey(rw As Range) As String
    Dim arr, x As Long, sep As String, rv As String
    arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 12)
    For x = LBound(arr) To UBound(arr)
        rv = rv & sep & rw.Cells(arr(x)).Value
        sep = Chr(0)
    Next x
    RowKey = rv
End Function
于 2013-10-25T16:05:47.937 回答