VBA 锯齿数组中的重复值

Question

我刚接触VBA编程，也是一个初学者。我有以下简单的表格（因为每天都会输入数据，所以它会发生变化）：

项目编号	描述	日期	位置	牌照	负载	类型	费率	成本
0001	des1	2021-01-30	现场	ABC123	5	一	typ1	100
0002	des2	2021-01-30	办公室	ACB465	4	一	typ1	100
0003	des3	2021-01-30	办公室	ABC789	3	一	typ1	100
0004	des4	2021-01-30	现场	ABS741	5	一	typ1	100
0005	des4	2021-01-31	办公室	ABC852	2	一	typ1	100

首先，我想按照特定日期过滤这些数据，然后在删除位置的重复项时，将这些重复项的负载相加。

例如，如果我想筛选出30/1/21的数据，结果应如下：

位置	负载量
站点	10
办公室	7

然后，我希望将其放入一个汇总单元格中，如下所示：

摘要
10 站点, 7 办公室

我已经能够将原始表格过滤成不规则数组。代码如下：

For j = numberSkipD To numberRowsD
    If Worksheets("Disposal Fees").Range("F" & j).Value = Worksheets("Daily Tracking").Range("B2").Value Then
        For k = numberDisposalInformationRaw To numberDisposalLocation
            ReDim Preserve disposalLocation(numberDisposalLocation)
            disposalLocation(numberDisposalLocation) = Worksheets("Disposal Fees").Range("I" & j).Value
 
        Next
        numberDisposalLocation = numberDisposalLocation + 1
 
        For k = numberDisposalInformationRaw To numberDisposalLoad
            ReDim Preserve disposalLoad(numberDisposalLoad)
            disposalLoad(numberDisposalLoad) = Worksheets("Disposal Fees").Range("K" & j).Value
        Next
        numberDisposalLoad = numberDisposalLoad + 1
    End If
Next

我尝试执行上面的第二张表（删除重复项并将这些重复项的值相加），但是出现了错误，不知道如何解决。我知道它们是索引错误，但不知道如何修复它们。（请帮我解决这个问题，以下是代码）

Dim disposalInformationRaw As Variant
    Dim disposalInformationCooked As Variant
    Dim FoundIndex As Variant, MaxRow As Long, m As Long
        
    ReDim disposalInformationCooked(1 To UBound(disposalInformationRaw, 1), 1 To UBound(disposalInformationRaw, 2))
    
    MaxRow = 0
    For m = 1 To UBound(disposalInformationRaw, 1)
        FoundIndex = Application.Match(disposalInformationRaw(m, 1), Application.Index(disposalInformationCooked, 0, 1), 0)

        If IsError(FoundIndex) Then
            MaxRow = MaxRow + 1
            FoundIndex = MaxRow
            disposalInformationCooked(FoundIndex, 1) = disposalInformationRaw(m, 1)
        End If

        disposalInformationCooked(FoundIndex, 2) = Val(disposalInformationCooked(FoundIndex, 2)) + Val(disposalInformationRaw(i, 2))
    Next m
    
    Range("G1").Resize(MaxRow, UBound(disposalInformationCooked, 2)).Value = disposalInformationCooked

我认为第三部分（总结）不会有太大的困难，但如果您知道如何做，请随意分享您的方法。我主要需要第二部分的帮助。如果需要，我很乐意进行编辑并提供更多信息。提前感谢。

- TheMoCrew

---

你需要第二张表格还是只需要最终的总结？ - Tim Williams

我需要得到最终的总结。也许有比我所做的更好的方法，但我不确定。 - TheMoCrew

Answer 1

这里提供一种使用字典的方法。

dim dict, rw as range, locn, k, msg, theDate

set dict= createobject("scripting.dictionary")

theDate = Worksheets("Daily Tracking").Range("B2").Value

'adjust table range as required
for each rw in worksheets("Disposal Fees").range("F6:K100").rows
   if rw.cells(3).Value = theDate Then              'date match?
       locn = rw.cells(4).Value                     'read location
       dict(locn) = dict(locn) + rw.cells(6).Value  'add load to sum
   end if
next rw

'loop over the dictionary keys and build the output
for each k in dict
    msg = msg & IIf(len(msg) > 0, ", ", "") & dict(k) & " " & k
next k

debug.print msg 

- Tim Williams

---

我认为这是正确的，但我觉得我在填空方面搞砸了。我按以下方式填写，并获得一些错误： [table range here] 为 worksheets("Disposal Fees").range("F6:K")[location col] 为 worksheets("Disposal Fees").range("I6:I") [load col] 为 worksheets("Disposal Fees").range("K6:I")我用作参考的工作表名为“处理费”。 列如下： F：日期 I：位置 K：负载 - TheMoCrew

对于 rw.cells([here])，只需在行中放置列号。 - Tim Williams

Answer 2

求和唯一

处理费用

每日追踪。

• 调整常量部分的值。

代码

Option Explicit

Sub TESTsumByValue()
    
    ' Source
    Const srcName As String = "Disposal Fees"
    Const lCol As Long = 3
    Const kCol As Long = 4
    Const sCol As Long = 6
    Const SumFirst As Boolean = True
    Const KSDel As String = ":"
    Const IDel As String = ", "
    ' Destination
    Const dstName As String = "Daily Tracking"
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    ' Define Source Range (You may have to do something different).
    Dim srg As Range: Set srg = wb.Worksheets(srcName).Range("A1").CurrentRegion
    
    ' Write Criteria to variable.
    Dim drg As Range: Set drg = wb.Worksheets(dstName).Range("B2")
    Dim Criteria As Variant: Criteria = drg.Value
    
    ' Use function to get the result.
    Dim s As String
    s = sumByValue(Criteria, srg, lCol, kCol, sCol, SumFirst, KSDel, IDel)
    Debug.Print s ' "10:Site, 4:Bathroom, 4:Office"
    
    drg.Offset(, 3).Value = s ' writes to 'E2'
    
End Sub

Function sumByValue( _
    ByVal LookupValue As Variant, _
    rng As Range, _
    ByVal LookupColumn As Long, _
    ByVal KeyColumn As Long, _
    ByVal SumColumn As Long, _
    Optional ByVal SumFirst As Boolean = False, _
    Optional ByVal KeySumDelimiter As String = ": ", _
    Optional ByVal ItemsDelimiter As String = ", ") _
As String
    
    ' Validate range ('rng').
    If rng Is Nothing Then Exit Function
    
    ' Write values from range to Data Array ('Data').
    Dim Data As Variant: Data = rng.Value ' 2D one-based array
    
    ' Declare additional variables.
    Dim vKey As Variant ' Current Key Value
    Dim vSum As Variant ' Current Sum Value
    Dim i As Long ' Data Array Row Counter
    
    ' Create a reference to Unique Sum Dictionary (no variable).
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare ' 'A = a'
        
        ' Loop through Data Array ('Data') and write and sumup unique values
        ' to Unique Sum Dictionary.
        For i = 1 To UBound(Data, 1)
            If Data(i, LookupColumn) = LookupValue Then
                vKey = Data(i, KeyColumn)
                If Not IsError(vKey) Then
                    If Len(vKey) > 0 Then
                        vSum = Data(i, SumColumn)
                        If IsNumeric(vSum) Then
                            .Item(vKey) = .Item(vKey) + vSum
                        Else
                            .Item(vKey) = .Item(vKey) + 0
                        End If
                    End If
                End If
            End If
        Next i
        
        ' Validate Unique Sum Dictionary.
        If .Count = 0 Then Exit Function
        
        ' Redefine variables to be reused.
        ReDim Data(1 To .Count) ' Result Array: 1D one-based array
        i = 0 ' Result Array Elements Counter
        
        ' Write results to Result Array.
        If SumFirst Then
            For Each vKey In .Keys
                i = i + 1
                Data(i) = .Item(vKey) & KeySumDelimiter & vKey
            Next vKey
        Else
            For Each vKey In .Keys
                i = i + 1
                Data(i) = vKey & KeySumDelimiter & .Item(vKey)
            Next vKey
        End If
    
    End With
    
    ' Write the elements of Data Array to Result String.
    sumByValue = Join(Data, ItemsDelimiter)

End Function

- VBasic2008