Excel'de yinelenenleri 2 sütundaki değerlere göre birleştir, toplamı ve ve diğerlerinden% üret, dupleri kaldır

Excel raporumla 2 sütun değerine dayanan yinelenen satırları almaya çalışırken mücadele ediyorum. Ayrıca 3. ve 4. sütunun toplamını hesaplamanız ve yüzdeyi hesaplamanız gerekir.

İşte veriler

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%

İşte şimdiye kadar denediklerim:

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

Sonuçlar için ne istediğini göstermiyorsun. Ancak yinelenenleri orijinal listenizde birleştiren bir tablo oluşturmak istediğiniz gibi geliyor. Bir sınıfı tanımlarım ve toplama nesnesini yinelemeleri test etmek ve birleştirmek için kullanırdım. Önceden var olan bir tuşa sahip bir nesne eklemeye çalışırsanız, toplama nesnesi bunun için kullanışlıdır. Sınıf, özellikler anlamlı adlara sahip olabileceğinden, en azından kodun daha anlaşılır olmasını sağlaması nedeniyle birçok nedenden dolayı kullanışlıdır. Ayrıca, tüm farklı dizileri takip etmeniz gerekmez.

İşte kod: Umarım anlaşılabilirdir, böylece gerçek verileriniz için gerektiği şekilde değiştirebilirsiniz.

Ve hangi hücreleri renklendirmek istediğinizden emin değilim. Renklendirmek istediğiniz kişi, kopyaları birleştirmenin sonucu olanlardır, bu mantık kolayca eklenebilir.

DÜZENLE Kodunuzu tekrar okuduktan sonra, kopyaları birleştirmenin sonucu olan satırları renklendirmek istediğiniz anlaşılıyor. Aşağıdaki kod buna göre değiştirildi. Bunu takip etmek için sınıf nesnesine (IsDup) bir işaretleyici ekleriz ve sonuçları yazarken kullanırız.

Sınıf Nesnesi

• Sınıf nesnesini yeniden adlandır Şarkılar

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

Normal modül

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

Örnek verileriniz göz önüne alındığında sonuçların sonuçları şöyle: