我有一些代码得到了帮助，可以跟踪一个键有多少重复项并对它们进行计数。现在，如果有多个键，我希望它能对每个键的项目进行汇总。这是我的计数项目。我一直在读关于.exists的文章，但不知道如何使用它。我已经花了好几天的时间来理解它。因此进行了调试。所以我只需要2列。第1列为关键，第2列为金额。我希望能够得到每把钥匙的总金额。显然我不知道自己在做什么。谢谢
'''代码'''
Public Sub TwoColumns()
Dim i As Long, j As Long, w As Long
Dim arr As Variant, dict As Object
Dim WS_Count As Integer
Dim rowString As String
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare
WS_Count = ActiveWorkbook.Worksheets.Count
rowString = ""
For w = 1 To WS_Count
With Worksheets(w)
arr = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
Debug.Print arr(1, 1) ' 23.1 which is C2
dict.RemoveAll
For i = LBound(arr, 1) To UBound(arr, 1)
rowString = arr(i, 1)
Debug.Print "rowString = " & rowString
Debug.Print "i =" & i & " j = " & j ' i = 1 j =0
For j = LBound(arr, 2) To UBound(arr, 2) ' assigns 1 to j??
Debug.Print "arr(i,j)" & arr(i, j) ' 23.1 which is C2
Debug.Print "2nd.For i =" & i & " j = " & j
dict.Item(arr(i, j)) = dict.Item(arr(i, j)) + 1
Debug.Print "arr(i,j)" & arr(i, j)
Next j
Next i
'return new values to worksheet
.Cells(1, "W").Resize(1, 2) = Array("%of Fund", "RBF525")
.Cells(2, "W").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
.Cells(2, "X").Resize(dict.Count, 1) = Application.Transpose(dict.items)
With .Range(.Cells(1, "W"), .Cells(.Rows.Count, "X").End(xlUp))
.Sort key1:=Columns(2), order1:=xlDescending, _
key2:=Columns(1), order2:=xlAscending, _
Header:=xlYes
End With
End With
Next w
End Sub
见下文-此处不需要j循环
Public Sub TwoColumns()
Dim i As Long, j As Long, w As Long, k, amt
Dim arr As Variant, dict As Object
Dim WS_Count As Long
Dim wb As Workbook
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare
Set wb = ActiveWorkbook
WS_Count = wb.Worksheets.Count
For w = 1 To WS_Count
With wb.Worksheets(w)
arr = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
Debug.Print arr(1, 1) ' 23.1 which is C2
dict.RemoveAll
For i = LBound(arr, 1) To UBound(arr, 1)
k = arr(i, 1) 'the key
amt = arr(i, 2) 'the amount
dict(k) = dict(k) + amt 'sum amount for this key
Next i
'return new values to worksheet
.Cells(1, "W").Resize(1, 2) = Array("%of Fund", "RBF525")
.Cells(2, "W").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
.Cells(2, "X").Resize(dict.Count, 1) = Application.Transpose(dict.items)
With .Range(.Cells(1, "W"), .Cells(.Rows.Count, "X").End(xlUp))
.Sort key1:=.Columns(2), order1:=xlDescending, _
key2:=.Columns(1), order2:=xlAscending, _
Header:=xlYes
End With
End With
Next w
创建唯一汇总表
- 这就是在几个函数的帮助下它的样子
Option Explicit
Sub CreateUniqueSumUpTables()
Const ProcName As String = "CreateUniqueSumUpTables"
On Error GoTo ClearError
Const sfRowRangeAddress As String = "C2:D2"
Const dfCellAddress As String = "W1"
Dim Headers As Variant: Headers = VBA.Array("%of Fund", "RBF525")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim srg As Range ' Source Range
Dim sfrrg As Range ' Source First Row (Data) Range
Dim dict As Object
Dim drg As Range ' Destination Range
Dim dfrrg As Range ' Destination First Row (Header) Range
Dim ddrg As Range ' Destination Data Range
Dim Data As Variant ' Source/Destination Array
For Each ws In wb.Worksheets
Set sfrrg = ws.Range(sfRowRangeAddress)
Set srg = RefColumns(sfrrg)
If Not srg Is Nothing Then
Data = GetRange(srg)
Set dict = DictArraySum(Data, 1, 2)
If Not dict Is Nothing Then
Data = GetDict(dict)
Set dfrrg = ws.Range(dfCellAddress).Resize(1, 2)
dfrrg.Value = Headers
Set drg = dfrrg.Resize(UBound(Data, 1) + 1)
Set ddrg = dfrrg.Resize(UBound(Data, 1)).Offset(1)
ddrg.Value = Data
drg.Sort Key1:=drg.Columns(2), Order1:=xlDescending, _
Key2:=drg.Columns(1), Order2:=xlAscending, Header:=xlYes
End If
End If
Next ws
MsgBox "Unique sum-up tables created.", vbInformation
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values from a column of a 2D array
' in the keys, and returns the corresponding sum of the values
' from another column of the array in the items of a dictionary.
' Remarks: Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictArraySum( _
ByVal sData As Variant, _
ByVal sKeyColumnIndex As Long, _
ByVal sItemColumnIndex As Long, _
Optional ByVal DoExcludeNotNumeric As Boolean = False, _
Optional ByVal DoExcludeZeros As Boolean = False) _
As Object
Const ProcName As String = "DictArraySum"
On Error GoTo ClearError
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim sKey As Variant
Dim sItem As Variant
Dim sr As Long
Dim DoNotSumUp As Boolean
For sr = LBound(sData) To UBound(sData)
sKey = sData(sr, sKeyColumnIndex)
If Not IsError(sKey) Then
If Len(CStr(sKey)) > 0 Then
sItem = sData(sr, sItemColumnIndex)
If IsNumeric(sItem) Then
If DoExcludeZeros Then
If sItem = 0 Then
DoNotSumUp = True
End If
End If
If DoNotSumUp Then
DoNotSumUp = False
Else
dDict(sKey) = dDict(sKey) + sItem
End If
Else
If Not DoExcludeNotNumeric Then
If Not DoExcludeZeros Then
dDict(sKey) = dDict(sKey) + 0
End If
End If
End If
End If
End If
Next sr
If dDict.Count = 0 Then Exit Function
Set DictArraySum = dDict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from a dictionary in a 2D one-based array.
' Remarks: F, F, F - returns the keys and items in two columns.
' F, F, T - returns the items and keys in two columns.
' F, T, F - returns the keys in a column.
' F, T, T - returns the items in a column.
' T, F, F - returns the keys and items in two rows.
' T, F, T - returns the items and keys in two rows.
' T, T, F - returns the keys in a row.
' T, T, T - returns the items in a row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDict( _
ByVal sDict As Object, _
Optional ByVal Horizontal As Boolean = False, _
Optional ByVal FirstOnly As Boolean = False, _
Optional ByVal Flip As Boolean = False) _
As Variant
Const ProcName As String = "GetDict"
On Error GoTo ClearError
Dim sCount As Long: sCount = sDict.Count
If sCount = 0 Then Exit Function
Dim Data As Variant
Dim Key As Variant
Dim i As Long
If Not Horizontal Then
If Not FirstOnly Then
ReDim Data(1 To sCount, 1 To 2)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = sDict(Key)
Data(i, 2) = Key
Next Key
End If
Else
ReDim Data(1 To sCount, 1 To 1)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = Key
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = sDict(Key)
Next Key
End If
End If
Else
If Not FirstOnly Then
ReDim Data(1 To 2, 1 To sCount)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = Key
Data(2, i) = sDict(Key)
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = sDict(Key)
Data(2, i) = Key
Next Key
End If
Else
ReDim Data(1 To 1, 1 To sCount)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = Key
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = sDict(Key)
Next Key
End If
End If
End If
GetDict = Data
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function