Объедините дубликаты в Excel на основе значений из 2 столбцов, выведите сумму и% от других, удалите дубликаты

Question

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

Вот данные

a1      b1          c1  d1  e1
disc1   song1234    3   20  15%
disc2   song78      2   30  7%
disc1   song54      1   10  10%
disc3   song4       4   10  40%
disc4   song0       1   15  7%
disc2   song78      2   16  13%
disc1   song1234    0   19  0%
disc4   song9       1   20  5%
disc1   song1234    0   10  0%

вот что я пробовал до сих пор:

Public Sub duplicateRollUp()

Application.ScreenUpdating = False      '
Dim SUMcols()                           '### declare a second empty array for our sum columns
Dim AVtemp()                            '### declare a third empty array for our temp values we need to calculate %
SUMcols() = Array(3, 4)          '### the second array stores the columns which should be summed up
Sheets("test").Select

   Dim LLoop As Integer
   Dim LTestLoop As Integer
   Dim LClearRange As String
   Dim Lrows As Integer
   Dim LRange As String

   'Column A values
   Dim LChangedValue As String
   Dim LTestValue As String

   'Column B values
   Dim LChangedValueB As String
   Dim LTestValueB As String

   'Test first 1000 rows in spreadsheet for uniqueness
   Lrows = 1000
   LLoop = 2

   'Clear all flags
   LClearRange = "A13:B" & Lrows
   Range(LClearRange).Interior.ColorIndex = xlNone

   'Check first 1000 rows in spreadsheet
   While LLoop <= Lrows
  LChangedValue = "A" & CStr(LLoop)
  LChangedValueB = "B" & CStr(LLoop)
  If Len(Range(LChangedValue).Value) > 0 Then

     'Test each value for dups
     LTestLoop = 2
     While LTestLoop <= Lrows
        If LLoop <> LTestLoop Then
           LTestValue = "A" & CStr(LTestLoop)
           LTestValueB = "B" & CStr(LTestLoop)
           'Value has been duplicated in another cell
           If (Range(LChangedValue).Value = Range(LTestValue).Value) And (Range(LChangedValueB).Value = Range(LTestValueB).Value) Then
              'Set the background color to yellow in column A
              Range(LChangedValue).Interior.ColorIndex = 6
              Range(LTestValue).Interior.ColorIndex = 6

              'Set the background color to yellow in column B
              Range(LChangedValueB).Interior.ColorIndex = 6
              Range(LTestValueB).Interior.ColorIndex = 6
           End If
        End If

        LTestLoop = LTestLoop + 1
     Wend

  End If

  LLoop = LLoop + 1

   Wend

Application.ScreenUpdating = True       '### re-enable our screen updating
End Sub                                 '### ends our macro

Answer 1

Вы не показываете, что вы хотите для результатов. Но, похоже, вы хотите создать таблицу, которая объединяет дубликаты в вашем исходном списке. Я бы определил класс и использовал объект коллекции для проверки на наличие дубликатов и объединения. Объект коллекции удобен для этого, поскольку он возвратит ошибку, если вы попытаетесь добавить объект с уже существующим ключом. Класс удобен по ряду причин, не в последнюю очередь из-за того, что он делает код более понятным, поскольку свойства могут иметь значимые имена. Кроме того, вам не нужно отслеживать все различные массивы.

Вот код: Надеюсь, он понятен, поэтому вы можете изменить его так, как вам нужно для ваших реальных данных.

И я не уверен, какие клетки вы хотите покрасить. Если вы хотите закрасить те, которые являются результатом объединения дубликатов, эту логику можно легко добавить.

РЕДАКТИРОВАТЬ После повторного чтения кода кажется, что вы хотите покрасить строки, которые являются результатом объединения дубликатов. Код ниже был изменен соответственно. Мы добавляем маркер в объект класса (IsDup), чтобы отслеживать это, и используем его, когда пишем результаты.

Объект класса

• Переименуйте объект класса cSongs

---

Option Explicit
Private pDisc As String
Private pSong As String
Private pC1_ As Long
Private pD1_ As Long
Private pE1_ As Double
Private pIsDup As Boolean

Public Property Get Disc() As String
    Disc = pDisc
End Property
Public Property Let Disc(Value As String)
    pDisc = Value
End Property

Public Property Get Song() As String
    Song = pSong
End Property
Public Property Let Song(Value As String)
    pSong = Value
End Property

Public Property Get C1_() As Long
    C1_ = pC1_
End Property
Public Property Let C1_(Value As Long)
    pC1_ = Value
End Property

Public Property Get D1_() As Long
    D1_ = pD1_
End Property
Public Property Let D1_(Value As Long)
    pD1_ = Value
End Property

Public Property Get E1_() As Double
    E1_ = Me.C1_ / Me.D1_
End Property

Public Property Get IsDup() As Boolean
    IsDup = pIsDup
End Property
Public Property Let IsDup(Value As Boolean)
    pIsDup = Value
End Property

---

Обычный модуль

---

Option Explicit
Sub GroupDiscSongs()
    Dim cS As cSongs, colS As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim I As Long
    Dim sKey As String
    Dim C As Range

'Set Source and Results worksheets and range
Set wsSrc = Worksheets("Sheet2")
Set wsRes = Worksheets("Sheet2")
    Set rRes = wsRes.Range("H1")

'Get Source Data
With wsSrc
    vSrc = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=4)
End With

'Collect Songs data and combine duplicates
Set colS = New Collection
On Error Resume Next 'to test for duplicates
For I = 2 To UBound(vSrc)
    Set cS = New cSongs
    With cS
        .Disc = vSrc(I, 1)
        .Song = vSrc(I, 2)
        .C1_ = vSrc(I, 3)
        .D1_ = vSrc(I, 4)
        .IsDup = False
        sKey = .Disc & "|" & .Song
        colS.Add cS, sKey
        If Err.Number = 457 Then
            Err.Clear
            With colS(sKey)
                .C1_ = .C1_ + cS.C1_
                .D1_ = .D1_ + cS.D1_
                .IsDup = True
            End With
        ElseIf Err.Number <> 0 Then
            Debug.Print Err.Number, Err.Description
            Stop
        End If
    End With
Next I
On Error GoTo 0

'Results array
ReDim vRes(0 To colS.Count, 1 To 5)

'Header row
    vRes(0, 1) = "a1"
    vRes(0, 2) = "b1"
    vRes(0, 3) = "c1"
    vRes(0, 4) = "d1"
    vRes(0, 5) = "e1"

'Data
For I = 1 To colS.Count
    With colS(I)
        vRes(I, 1) = .Disc
        vRes(I, 2) = .Song
        vRes(I, 3) = .C1_
        vRes(I, 4) = .D1_
        vRes(I, 5) = .E1_
        'add marker for duplicate for conditional formatting
        If .IsDup Then vRes(I, 1) = Chr(2) & vRes(I, 1)
    End With
Next I

'Write the results
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Columns(5).NumberFormat = "0%"
    .EntireColumn.AutoFit
    .EntireColumn.ColumnWidth = .Columns(2).ColumnWidth

'Color rows from dups and remove marker
    Set C = .Columns(1).Find(what:=Chr(2), LookIn:=xlValues, lookat:=xlPart)
        If Not C Is Nothing Then
            C = Mid(C, 2) 'remove the marker
            .Rows(C.Row).Interior.ColorIndex = 6
            Do
                Set C = .Columns(1).FindNext(C)
                If Not C Is Nothing Then
                    C = Mid(C, 2)
                    .Rows(C.Row).Interior.ColorIndex = 6
                End If
            Loop Until C Is Nothing
        End If

    .Sort key1:=.Columns(1), order1:=xlAscending, _
                key2:=.Columns(2), order2:=xlAscending, _
                MatchCase:=False, Header:=xlYes
End With
Application.ScreenUpdating = True

End Sub

---

Вот как выглядят результаты, учитывая ваши примерные данные: