Question

我创建了一些代码来查看上一行，如果列D和F匹配，那么它将添加G和K列的结果并删除结果。

这仍然会在我的数据中留下重复数据，因为并非所有重复项都按顺序排列（彼此相邻）

您能否告诉我如何搜索所有行并执行上面所说的直到根本没有匹配。

Sub Merge_Values()
Dim lngRow As Long
Dim columnToMatch1 As Range
Dim columnToMatch2 As Range
Dim columnToSum1 As Range
Dim columnToSum2 As Range
Dim MatchChecker As Boolean

MatchChecker = False

With ActiveSheet
    Set columnToMatch1 = .Range("D:D")
    Set columnToMatch2 = .Range("F:F")
    Set columnToSum1 = .Range("G:G")
    Set columnToSum2 = .Range("K:K")

    lngRow = .Range(columnToMatch1, columnToMatch2).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Do While Not lngRow = 9
        For x = columnToMatch1.Column To columnToMatch2.Column
            If .Cells(lngRow, x) = .Cells(lngRow - 1, x) Then
                MatchChecker = True
            Else
                MatchChecker = False
                Exit For
            End If
        Next x
        If MatchChecker = True Then
            For y = columnToSum1.Column To columnToSum2.Column
                .Cells(lngRow - 1, y) = .Cells(lngRow - 1, y) + .Cells(lngRow, y)
            Next y
                .Rows(lngRow).Delete
        End If
        lngRow = lngRow - 1
    Loop    
 End With
End Sub

我认为我需要一些东西而不是 lngRow -1 ，但我不确定我可以放在这里继续搜索所有内容。

OR

我可能需要把它全部放在另一个'Do while'声明中，但我不能让任何事情变得有意义请帮忙。

Answer 1

以下是使用字典对象的示例：

Sub Merge_Values()

Const START_ROW As Long = 10

Dim firstRw As Long
Dim dict As Object, rngDelete As Range
Dim arrMatchCols, arrSumCols, i As Long
Dim rw As Range, k As String, tmp, noValue as Boolean, sep As String

    Set dict = CreateObject("scripting.dictionary")
    arrMatchCols = Array(4, 5, 6)       'composite key
    arrSumCols = Array(7, 8, 9, 10, 11) 'columns to sum

    With ActiveSheet

        Set rw = .Rows(START_ROW)

        Do
            k = ""
            noValue = True
            sep = ""
            For i = LBound(arrMatchCols) To UBound(arrMatchCols)
                tmp = rw.Cells(arrMatchCols(i)).Value
                If Len(tmp) > 0 Then noValue = False
                k = k & sep & tmp
                sep = vbNull
            Next i
            If noValue Then Exit Do 'no more rows - exit loop

            If dict.exists(k) Then 'not first time for this combination...
                firstRw = dict(k) 'get first row

                'loop though "sum" columns and add values to first row
                For i = LBound(arrSumCols) To UBound(arrSumCols)
                    With .Rows(firstRw).Cells(arrSumCols(i))
                        .Value = .Value + rw.Cells(arrSumCols(i)).Value
                    End With
                Next i

                'build range to delete
                If rngDelete Is Nothing Then
                    Set rngDelete = rw
                Else
                    Set rngDelete = Application.Union(rngDelete, rw)
                End If
            Else
                dict(k) = rw.Row 'first time for this key: save row value
            End If

            Set rw = rw.Offset(1, 0) 'next row
        Loop

    End With

    'delete duplicates if found
    If Not rngDelete Is Nothing Then rngDelete.Delete

End Sub

在行中搜索重复项

1 个答案: