首页 文章

使用VBA在Excel中快速合并重复项

提问于
浏览 次
0

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

这个想法是，如果2行或更多行具有相同的A B C列，我认为他们的D列删除ABC重复 . 我需要这样做，但检查更多的colums .

我的宏看起来像这样：

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中运行这个宏，并且它需要花费很多时间才不再实用 .

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

有任何想法吗？

excel vba excel-vba

1 回答

  • 1

    EDITED: 我错过了你没有检查每一列以确定什么是重复 . 现在应该更近了：

    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
    回复于

相关问题