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

这列A列的值与列B的唯一值相加。我如何扩展这一点，这样不仅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

MS Excel宏删除重复行并对其值求和

1 个答案: