问题描述
我是使用 VBA 编码的新手，一般来说也是初学者。我有以下简单的表格（数据每天都在不断输入，因此会发生变化）：
| 项目# | 描述 | 日期 | 位置 | 板 | 加载 | 输入 | 率 | 成本 |
|---|---|---|---|---|---|---|---|---|
| 0001 | des1 | 30/1/21 | 网站 | ABC123 | 5 | 一个 | typ1 | 100 |
| 0002 | des2 | 30/1/21 | 办公室 | ACB465 | 4 | 一个 | typ1 | 100 |
| 0003 | des3 | 30/1/21 | 办公室 | ABC789 | 3 | 一个 | typ1 | 100 |
| 0004 | des4 | 30/1/21 | 网站 | ABS741 | 5 | 一个 | typ1 | 100 |
| 0005 | des4 | 31/1/21 | 办公室 | 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,Application.Index(disposalinformationCooked,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
我认为完成第三部分（摘要）不会有太多麻烦，但如果您知道如何完成，请随时分享您将如何处理它。我主要需要第二部分的帮助。如果需要，我非常乐意编辑并提供更多信息。提前致谢。
解决方法
这是使用字典的一种方法。
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
总和唯一
处理费用
每日跟踪
- 调整常量部分中的值。
代码
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