Всего повторяющихся строк - PullRequest
Новая
       20

Всего повторяющихся строк

0 голосов
/ 28 апреля 2020

Так что я знаю, что этот вопрос задавали снова и снова, но просматривая все посты и создавая код, я не могу заставить свой работать. Я приложил пример того, как выглядят мои данные и как они должны выглядеть. Моя проблема в том, что код вставляет первый столбец, который мне не нужен, и он не складывает все дублирующиеся строки вместе.

как выглядят данные ( Данные ), должны выглядеть ( Нужны ) и выглядят как ( Get ): what data looks like

Я попробовал следующий код: 

Dim ar As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim str As String

n = 2
ar = Worksheets("bom_wo_header").Cells(4, 1).CurrentRegion.value
With CreateObject("Scripting.Dictionary")
    For i = 3 To UBound(ar, 1)
        str = ar(i, 5)
        If Not .exists(str) Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                ar(n, j) = ar(i, j)
            Next j
            .Item(str) = n
        Else
            j = 3
            ar(.Item(str), j) = ar(.Item(str), j) + ar(i, j)
        End If
    Next i
End With
Worksheets("totals").Range("A1").Resize(n, UBound(ar, 2)).value = ar

1 Ответ

0 голосов
/ 28 апреля 2020

Ваш код гораздо динамичнее c, но, учитывая то, как представлены ваши данные, вам может не потребоваться учитывать столько вещей.

Это то, что я сделал и получил желаемый результат. При необходимости измените / добавьте диапазоны.

enter image description here

Sub Unique_List_Sum()

'First generate unique list for products**************

Dim X
Dim objDict As Object
Dim lngRow As Long
Dim r As Range

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([B1], Cells(Rows.Count, "B").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("E1:E" & objDict.Count) = Application.Transpose(objDict.keys)

'Secont sumif each unique*****************

Set r = ActiveSheet.Range("E2:E" & objDict.Count) 'no need to sum "Product"

For Each prod In r

'end loop at blank cell
    If prod = "" Then
        Exit For
            End If

prod.Offset(0, 1).Value = Application.WorksheetFunction.SumIf(Range("B:B"), prod, Range("A:A"))

Next prod


End Sub

Кредит метода уникального списка: Заполнение уникальных значений в массив VBA из Excel user brettdj

****** Если значение вашего снимка экрана «Данные:» находится в ячейке A1, измените имена вкладок на «Madds Data» и «Madds Output», и это запустится для вас: 

Sub Madds_Dups()

Sheets("Madds Data").Select
Range("E:E").Copy Destination:=Sheets("Madds Output").Range("A1")
Sheets("Madds Output").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Sheets("Madds Output").Select

'delete blank row
Rows("1:1").Select
Selection.Delete shift:=xlUp

'Loop sums
Set r = ActiveSheet.Range("A2:A1000")

For Each prod In r

'end loop at blank cell
    If prod = "" Then
        Exit For
            End If

prod.Offset(0, 1).Value = Application.WorksheetFunction.SumIf(Sheets("Madds Data").Range("E:E"), prod, Sheets("Madds Data").Range("C:C"))

Next prod

End Sub
...