Question

我有一个 Excel 工作表，其中某些行可能包含与其他行相同的数据。我需要一个宏来汇总该列中的所有值并删除所有重复行，除了第一个包含其余行的总和。

我尝试了多个版本的代码，产生最接近我需要的结果的代码如下所示，但这段代码包含一个问题：无限循环。

Sub delet()
    Dim b As Integer
    Dim y As Worksheet
    Dim j As Double
    Dim k As Double

    Set y = ThisWorkbook.Worksheets("Sheet1")
    b = y.Cells(Rows.Count, 2).End(xlUp).Row

    For j = 1 To b
        For k = j + 1 To b
            If Cells(j, 2).Value = Cells(k, 2).Value Then
                Cells(j, 3).Value = (Cells(j, 3).Value + Cells(k, 3).Value)
                Rows(k).EntireRow.Delete
                k = k - 1
            ElseIf Cells(j, 2).Value <> Cells(k, 2).Value Then
                k = k
            End If
        Next
    Next
End Sub

Answer 1

我会建议获取数组中的数据，然后进行相关操作。这是一个很小的范围，它可能不会影响性能，但对于更大的数据集，它会很重要。

这是你正在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, j As Long
    Dim MyAr As Variant, outputAr As Variant
    Dim col As New Collection
    Dim itm As Variant
    Dim totQty As Double
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        '~~> Find last row of col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Get those value in an array
        MyAr = .Range("A2:C" & lRow).Value2
        
        '~~> Get unique collection of Fam.
        For i = LBound(MyAr) To UBound(MyAr)
            If Len(Trim(MyAr(i, 2))) <> 0 Then
                On Error Resume Next
                col.Add MyAr(i, 2), CStr(MyAr(i, 2))
                On Error GoTo 0
            End If
        Next i
        
        '~~> Prepare array for output
        ReDim outputAr(1 To col.Count, 1 To 3)
        
        i = 1
        
        For Each itm In col
            '~~> Get Product
            For j = LBound(MyAr) To UBound(MyAr)
                If MyAr(i, 2) = itm Then
                    outputAr(i, 1) = MyAr(i, 1)
                    Exit For
                End If
            Next j
            
            '~~> Fam.
            outputAr(i, 2) = itm
            
            totQty = 0
            
            '~~> Qty
            For j = LBound(MyAr) To UBound(MyAr)
                If MyAr(j, 2) = itm Then
                    totQty = totQty + Val(MyAr(j, 3))
                End If
            Next j
            
            outputAr(i, 3) = totQty
            
            i = i + 1
        Next itm
        
        '~~> Copy headers
        .Range("A1:C1").Copy .Range("G1")
        '~~> Write array to relevant range
        .Range("G2").Resize(UBound(outputAr), 3).Value = outputAr
    End With
End Sub

输出

Answer 2

如果 VBA 不是必需的，而您有 365：

在单元格 return a result(with CSV file) to first one 中输入公式 G2
在单元格 =UNIQUE(A2:B11) 中输入公式 I2

Answer 3

用总和删除重复项

调整常量部分中的值。
请注意，如果您选择相同的工作表和 "A1"，您将被覆盖。

代码

Option Explicit

Sub removeDupesSum()
    
    Const sName As String = "Sheet1"
    Const dName As String = "Sheet1"
    Const dFirst As String = "G1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write values from Source Range to Data Array.
    Dim Data As Variant
    Data = wb.Worksheets(sName).Cells(1).CurrentRegion.Value
    
    ' Write unique values from Data Array to Unique Sum Dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim arr As Variant: ReDim arr(2 To UBound(Data, 1)) ' for first column
    Dim n As Long: n = 1
    Dim i As Long
    For i = 2 To UBound(Data, 1)
        If dict.Exists(Data(i, 2)) Then
            dict(Data(i, 2)) = dict(Data(i, 2)) + Data(i, 3)
        Else
            n = n + 1
            arr(n) = Data(i, 1)
            dict(Data(i, 2)) = Data(i, 3)
        End If
    Next i
    
    Dim Result As Variant: ReDim Result(1 To dict.Count + 1, 1 To 3)
    ' Write headers.
    For i = 1 To 3
        Result(1, i) = Data(1, i)
    Next i
    Erase Data
    ' Write 'body'.
    Dim Key As Variant
    i = 1
    For Each Key In dict.Keys
        i = i + 1
        Result(i, 1) = arr(i)
        Result(i, 2) = Key
        Result(i, 3) = dict(Key)
    Next Key
    
    ' Write values from Result Array to Destination Range.
    With wb.Worksheets(dName).Range(dFirst).Resize(, 3)
        .Resize(i).Value = Result
        .Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
    End With

End Sub

根据单元格值汇总行，然后删除所有重复项

3 个答案:

用总和删除重复项