时间戳

首页 > 解决方案 > 删除列中的重复项并在另一列中输入 Sum

excel - 删除列中的重复项并在另一列中输入 Sum

问题描述

我想根据 I 列中的文本删除重复项并对 C 列中的值求和，其他列中的数据无关紧要。

我不想要数据透视表，而且我知道它们是这类事物的首选。

我想实现的一个例子：

对于这个数据

以这样的方式结束

我找到了 VBA 代码并试图修改它。它不会删除所有行。

Sub Sum_and_Dedupe()
With Worksheets("data")
    'deal with the block of data radiating out from A1
    With .Cells(1, 1).CurrentRegion
        'step off the header and make one column wider
        With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
            .Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
            .Columns(3) = .Columns(.Columns.Count).Value
            .Columns(.Columns.Count).Delete
        End With

        'remove duplicates
        .RemoveDuplicates Columns:=Array(9), Header:=xlYes
    End With
    .UsedRange
End With
End Sub

标签： excelvba

解决方案

您需要将当前工作表名称更改为data，或者更改此代码的前两行以满足您的需要。sh= 您向我们展示的数据表。osh= 此代码将生成的输出表。另请注意，如果 C 列或 I 列移动，您可以通过更改colBooked和轻松更新位置colEstimate。如果您有超过一千个唯一估计条目，则使数组编号大于 999。

Sub summariseEstimates()
    Dim sh As String: sh = "data"
    Dim osh As String: osh = "summary"
    Dim colBooked As Integer: colBooked = 3
    Dim colEstimate As Integer: colEstimate = 9
    Dim myArray(999) As String
    Dim shCheck As Worksheet
    Dim output As Worksheet
    Dim lastRow As Long
    Dim a As Integer: a = 0
    Dim b As Integer
    Dim r As Long 'row anchor
    Dim i As Integer 'sheets

    'Build summary array:
    With Worksheets(sh)
        lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        For r = 2 To lastRow
            If r = 2 Then 'first entry
                myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
            Else
                For b = 0 To a
                    If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
                        myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
                        Exit For
                    End If
                Next b
                If b = a + 1 Then 'completed loop = no match, create new array item:
                    a = a + 1
                    myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
                End If
            End If
        Next r
    End With

    'Create summary sheet:
    On Error Resume Next
    Set shCheck = Worksheets(osh)
    If Err.Number <> 0 Then
        On Error GoTo 0
        Set output = Worksheets.Add(After:=Worksheets(sh))
        output.Name = osh
        Err.Clear
    Else
        On Error GoTo 0
        If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
            Exit Sub
        Else
            Application.DisplayAlerts = False
            Worksheets(osh).Delete
            Set output = Worksheets.Add(After:=Worksheets(sh))
            output.Name = osh
        End If
    End If

    'Output to summary sheet:
    With Worksheets(osh)
        .Cells(1, 1).Value = "ESTIMATE"
        .Cells(1, 2).Value = "BOOKED THIS WEEK"
        For b = 0 To a
            .Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
            .Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
        Next b
        .Columns("A:B").AutoFit
    End With

End Sub

推荐阅读