Удалите дубликаты в столбце и введите сумму в другой столбец

Question

Я хочу удалить дубликаты на основе текста в столбце 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

Answer 1

Это должен быть ответ на ваш вопрос.Однако код может потребовать адаптации, если диапазон, в котором вы смотрите, становится очень длинным.

Опция Явная

Sub test()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim LastRow As Long, LastCol As Long, a As Double, i As Long
    Dim Rng As Range
    Dim Cell As Variant, Estimate As Variant

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)

    LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))


    For Each Cell In Rng
        i = 0
        a = 0
        For Each Estimate In Rng
            If Estimate.Value = Cell.Value Then
                i = i + 1   'Count nr of intances
                a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
                If i > 1 Then
                    ws.Rows(Estimate.Row).Delete
                    i = 1
                    LastRow = LastRow - 1
                End If
            End If
        Next Estimate
        ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
    Next Cell

End Sub

Answer 2

Вам нужно либо изменить текущее имя листа на data , либо изменить первые две строки этого кода в соответствии с вашими потребностями.sh = лист данных, который вы нам показали.osh = выходной лист, который сгенерирует этот код.Обратите внимание также, что если столбец C или я перемещаются, вы можете легко обновить позиции, изменив 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