MS Excel宏删除重复的行并将它们的值相加

Question

我非常简短地熟悉vba，并且我无法弄清楚如何修改以下脚本以使其符合我的预期。

基本上我有5列excel。列A是我想总结的价值观，提供B和C和D和E是作为行唯一的。

我发现下面的脚本，它确实几乎我需要什么：

Option Explicit 

Sub RedoDataset() 
Dim LastCol As Long 
Dim LastRowData As Long 
Dim LastRow As Long 
Dim Ctr As Long 

Dim CompanyArr 
Dim RowFoundArr 
Dim SumArr 
Dim Rng As Range 
Dim SettingsArray(1 To 2) As Integer 

On Error Resume Next 
With Application 
    SettingsArray(1) = .Calculation 
    SettingsArray(2) = .ErrorCheckingOptions.BackgroundChecking 
    .Calculation = xlCalculationManual 
    .EnableEvents = False 
    .ErrorCheckingOptions.BackgroundChecking = False 
    .ScreenUpdating = False 
End With 
On Error GoTo 0 

With ThisWorkbook 
    With .Sheets("Sheet1") 
     LastRowData = .Cells(Rows.Count, 1).End(xlUp).Row 
     LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column 
     Set Rng = .Range(.Cells(1, 1), .Cells(1, LastCol)) 

     .Columns(2).AdvancedFilter Action:=xlFilterCopy, _ 
     CopyToRange:=.Cells(1, LastCol + 2), Unique:=True 

     LastRow = .Cells(Rows.Count, LastCol + 2).End(xlUp).Row 

     ReDim CompanyArr(1 To LastRow - 1) 
     ReDim RowFoundArr(1 To LastRow - 1) 
     ReDim SumArr(1 To LastRow - 1) 

     For Ctr = 1 To LastRow - 1 
      CompanyArr(Ctr) = .Cells(Ctr + 1, LastCol + 2) 
      RowFoundArr(Ctr) = Application.Match(CompanyArr(Ctr), .Columns(2), 0) 
      SumArr(Ctr) = Application.SumIf(.Columns(2), CompanyArr(Ctr), .Columns(1)) 
      .Cells(RowFoundArr(Ctr), 1) = SumArr(Ctr) 

      Set Rng = Union(Rng, .Range(.Cells(RowFoundArr(Ctr), 1), _ 
      .Cells(RowFoundArr(Ctr), LastCol))) 
     Next Ctr 
     .Columns(LastCol + 2).Delete 

     For Ctr = LastRowData To 2 Step -1 
      If IsError(Application.Match(Ctr, RowFoundArr, 0)) Then 
       .Rows(Ctr).Delete 
      End If 
     Next Ctr 

    End With 
End With 

On Error Resume Next 
With Application 
    .Calculation = SettingsArray(1) 
    .ErrorCheckingOptions.BackgroundChecking = SettingsArray(2) 
    .EnableEvents = True 
    .ScreenUpdating = True 
    .ScreenUpdating = True 
End With 
On Error GoTo 0 


End Sub 

这个总结离开B柱独特的A列的值。我怎么这么延长这不仅B是唯一的，但条件是 - B和C和D和E是组合作为行唯一的。 基本上在全行唯一比较等，但没有必要每列包含唯一的值：

A B  C  D  E 
1 0.01 La Ba  foo boo 
2 0.03 La boo foo Ba 
3 0.12 La foo Ba  boo 
4 1.05 Ba La  foo boo 

Answer 1

试试这个代码 - 它采用了不同的方法，这是更灵活：

Const cStrDelimiter As String = ";" 

Sub Aggregate() 
    Dim dic As Object 
    Dim rng As Range 
    Dim strCompound As String 
    Dim varKey As Variant 
    Set dic = CreateObject("Scripting.Dictionary") 

    'Store all unique combinations in a dictionary 
    Set rng = Worksheets("Sheet1").Range("A1") 
    While rng <> "" 
     strCompound = fctStrCompound(rng.Offset(, 1).Resize(, 4)) 
     dic(strCompound) = dic(strCompound) + rng.Value 
     Set rng = rng.Offset(1) 
    Wend 

    'Save all unique, aggregated elements in worksheet 
    Set rng = Worksheets("Sheet1").Range("G1") 
    For Each varKey In dic.Keys 
     rng = dic(varKey) 
     rng.Offset(, 1).Resize(, 4).Cells = Split(varKey, cStrDelimiter) 
     Set rng = rng.Offset(1) 
    Next 
End Sub 

Private Function fctStrCompound(rngSource As Range) As String 
    Dim strTemp As String 
    Dim rng As Range 
    For Each rng In rngSource.Cells 
     strTemp = strTemp & rng.Value & cStrDelimiter 
    Next 
    fctStrCompound = Left(strTemp, Len(strTemp) - Len(cStrDelimiter)) 
End Function