☰

根据两列的值合并 Excel 中的重复项，计算总和以及与其他值的百分比，删除重复项

tag-icon • tag-icon microsoft-excel vba macros
根据两列的值合并 Excel 中的重复项，计算总和以及与其他值的百分比，删除重复项

我一直在努力制作 Excel 报告，尝试根据 2 列值汇总重复行。还需要计算第 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

答案1

您没有显示您想要的结果。但听起来您想生成一个将原始列表中的重复项组合在一起的表。我将定义一个类，并使用集合对象来测试重复项并进行组合。集合对象对此很方便，因为如果您尝试添加具有预先存在的键的对象，它将返回错误。类很方便，原因有很多，其中最重要的一点是它使代码更易于理解，因为属性可以具有有意义的名称。而且，您不必跟踪所有不同的数组。

这是代码：希望它是可以理解的，以便您可以根据您的实际数据需要对其进行修改。

而且，我不确定你想给哪些单元格上色。如果你想要给那些单元格上色，那么就可以轻松添加该逻辑。

编辑重新阅读代码后，您似乎想要为合并重复项的结果行着色。下面的代码已进行了相应修改。我们向类对象 (IsDup) 添加一个标记来跟踪这一点，并在写入结果时使用它。

类对象

  • 重命名类对象歌曲
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

根据样本数据，结果如下：

在此处输入图片描述

相关内容