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 で実行する必要があり、時間がかかりすぎて実用的ではなくなりました。

これは、VBA を使用した Excel での最初のマクロです。個別にアクセスすると非常に遅いように見えるため、行/セルを処理するより高速な方法があるかどうか疑問に思っていました。

何か案は？

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 に答える