如何基于相似项求和？ (VBA)

Question

我正在尝试根据类似条件（例如日期、项目和存储桶）对值求和。以下是我正在使用的测试数据：

Date	Project	Bucket	Hours
2022-03-28	ALN-1150	Time Bucket	1
2022-03-28	ALN-1150	Time Bucket	1
2022-03-28	ALN-1150	Time Bucket	2.5
2022-03-29	ALN-1150	Time Bucket	3
2022-03-29	ALN-1150	Time Bucket	2
2022-03-30	ALN-1500	Time Bucket	1
2022-03-30	ALN-1500	OMSH225	1

我尝试使用以下方法检查有多少相似项，但这只适用于第一次约会，之后就停止了...

Sub addTime()

    Dim CountRows As Integer
    Dim Counter As Integer
    
    CountRow = 1
    Counter = 1
    
    
    Do While Len(Sheets("Formatting").Range("A1").Offset(rowOffset:=CountRow)) > 0
        Do While Sheets("Formatting").Range("A1").Offset(rowOffset:=Counter).Value = Sheets("Formatting").Range("A1").Offset(rowOffset:=(Counter + 1)).Value _
            And Sheets("Formatting").Range("B1").Offset(rowOffset:=Counter).Value = Sheets("Formatting").Range("B1").Offset(rowOffset:=(Counter + 1)).Value _
            And Sheets("Formatting").Range("C1").Offset(rowOffset:=Counter).Value = Sheets("Formatting").Range("C1").Offset(rowOffset:=(Counter + 1)).Value _
            
            Counter = Counter + 1

        Loop
        
        CountRow = CountRow + 1
    Loop
    
    Debug.Print "Number of like Values: " + CStr(Counter)

End Sub

我期待的是：

Date	Project	Bucket	Hours	Total
2022-03-28	ALN-1150	Time Bucket	1	4.5
2022-03-28	ALN-1150	Time Bucket	1
2022-03-28	ALN-1150	Time Bucket	2.5
2022-03-29	ALN-1150	Time Bucket	3	5
2022-03-29	ALN-1150	Time Bucket	2
2022-03-30	ALN-1500	Time Bucket	1	1
2022-03-30	ALN-1500	OMSH225	1	1

非常感谢任何帮助，因为我整天都被困在这个问题上。谢谢

Answer 1

我不清楚你是想要计数还是总计，所以我提供了两者兼顾的代码。您可以轻松修改以删除不需要的值。

Dim LastRow As Integer
Dim i As Integer
Dim Count As Integer
Dim FirstRowInGroup As Long
Dim RunningTotal As Double

    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    FirstRowInGroup = 2
    Count = 1

    For i = 2 To LastRow - 1
        If i = FirstRowInGroup Then
            RunningTotal = Cells(i, 4)
        End If
        If Cells(i, 1) = Cells(i + 1, 1) And _
        Cells(i, 2) = Cells(i + 1, 2) And _
        Cells(i, 3) = Cells(i + 1, 3) Then
            Count = Count + 1
            RunningTotal = RunningTotal + Cells(i + 1, 4)
        Else
            Cells(FirstRowInGroup, 5) = Count
            Cells(FirstRowInGroup, 6) = RunningTotal
            Count = 1
            FirstRowInGroup = i + 1
        End If
    Next
    
    'Deal with last row being different
    If Cells(LastRow, 1) <> Cells(LastRow - 1, 1) Or _
    Cells(LastRow, 2) <> Cells(LastRow - 1, 2) Or _
    Cells(LastRow, 3) <> Cells(LastRow - 1, 3) Then
        Cells(LastRow, 5) = 1
        Cells(LastRow, 6) = Cells(LastRow, 4)
    End If

请注意，此解决方案取决于连续（组合在一起）的相似项目，如您的样本数据中所示。如果不是这种情况，那么您需要先对数据进行排序（基于三个“类似”列）。如果出于某种原因不切实际，那么我可以为您提供替代解决方案。

Answer 2

也许可以试试下面的方法：

Sub addTime()

Dim SumHours As Double

Dim sh As Worksheet
Dim rng As Range
Dim row As Range

Dim arr(3) As Variant

Set sh = ThisWorkbook.Sheets("Formatting")
Set rng = sh.Range("A2:E8") 'expand as necessary or write function to obtain the total range to be checked

SumHours = 0
equal = False
arr(0) = 2
For Each row In rng.Rows

    equal = (arr(1) = row.Cells(1, 1) And arr(2) = row.Cells(1, 2) And arr(3) = row.Cells(1, 3))
    
    If (Not equal) Then
        sh.Cells(arr(0), 5) = SumHours
        arr(0) = row.row
        arr(1) = row.Cells(1, 1)
        arr(2) = row.Cells(1, 2)
        arr(3) = row.Cells(1, 3)            
        SumHours = row.Cells(1, 4)
    ElseIf equal Then
        SumHours = SumHours + row.Cells(1, 4)
    End If

Next

End Sub

它循环遍历范围内的所有行并存储第一个值的行，然后只要所有三个单元格值都相等就继续对值求和？

您可能需要编写一个 returns 一个 Range 的函数，以便您可以适当地确定有效范围。

这会产生以下结果：

Answer 3

如果出于某种原因需要 VBA，您可以使用 ADODB 库来实现。结果将独立于行的顺序。相似的行不需要组合在一起。另一方面，代码将为每一行在右侧打印您可能不想要的结果。

Option Explicit

Sub mySumIfS()

    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sSQL As String
    Dim xlFile As String
    xlFile = ThisWorkbook.FullName

    ' connect to this workbook
    With cn
        .Provider = "Microsoft.ACE.OLEDB.16.0"
        .ConnectionString = "Data Source=" & xlFile & "; Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
        .Open
    End With
    
    ' the result of this SQL staetement is the sum of hours grouped by Date and Bucket
    sSQL = "SELECT Date, Bucket, Sum(Hours) AS Total FROM [Sheet1$] GROUP BY Date, Bucket;"
    Set rs = cn.Execute(sSQL)
    
    
    Dim rg As Range, sngRow As Range, wks As Worksheet
    Set wks = ActiveSheet
    Set rg = wks.Range("A1").CurrentRegion
    Set rg = rg.Offset(1).Resize(rg.Rows.CountLarge - 1)
        
    ' Loop through the input data
    ' filter the result by Date and bucket
    ' print the total of hours to the right
    For Each sngRow In rg.Rows
        rs.Filter = "[Date] = " & sngRow.Cells(1, 1).Value & " AND [Bucket] = '" & sngRow.Cells(1, 3).Value & "'"
        sngRow.Cells(1, 1).Offset(, 4).Value = rs.Fields(2).Value
    Next

End Sub

如果您确实想计算而不是总数，您只需要稍微更改 SQL 语句

sSQL = "SELECT Date, Bucket, Count(Hours) AS Total FROM [Sheet1$] GROUP BY Date, Bucket;"

如何基于相似项求和？ (VBA)

How to Sum Values Based on Like-Items? (VBA)

excel

vba