Excel 合并重复的行并使用字典对值求和
我有一个如下所示的表格，基于黄色突出显示的列，我需要对绿色突出显示的列求和 预期产出如下： 我已经用下面的代码完成了Excel 合并重复的行并使用字典对值求和,excel,vba,Excel,Vba,我有一个如下所示的表格，基于黄色突出显示的列，我需要对绿色突出显示的列求和 预期产出如下： 我已经用下面的代码完成了 Sub test() lrow = ActiveSheet.Cells(ActiveSheet.Cells.Rows.Count, 1).End(xlUp).Row Set Rng = Range("A2:A" & lrow) For Each cell In Rng If Not IsEmpty(cell) Then
Sub test()
lrow = ActiveSheet.Cells(ActiveSheet.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A2:A" & lrow)
For Each cell In Rng
If Not IsEmpty(cell) Then
a = cell
b = cell.Offset(0, 1)
c = cell.Offset(0, 5)
r = cell.Row
cnt = Application.WorksheetFunction.CountIf(Rng, cell)
d = 0
For i = 1 To cnt
If Cells(r + i, 1) = a And Cells(r + i, 2) = b And Cells(r + i, 6) Then
Cells(r, 7) = Cells(r + i, 7) + Cells(r, 7)
Cells(r, 8) = Cells(r + i, 8) + Cells(r, 8)
d = d + 1
End If
Next
If d > 0 Then Range(Cells(r + 1, 1).Address, Cells(r + d, 1).Address).EntireRow.Delete
End If
Next
End Sub
有人能帮我吗？如果可能的话，请附上一些注释。我会这样做：
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim arrData As Variant
Dim i As Long, ConcatenateStr As String, Sum1 As Currency, Sum2 As Currency
Dim DictSum1 As Scripting.Dictionary 'You need the Microsoft Scripting Runtime reference for this to work
Dim DictSum2 As Scripting.Dictionary
Set ws = ThisWorkbook.Sheets("SheetName") 'Change this to fit your sheet name
Set DictSum1 = New Scripting.Dictionary 'This is how you initialize your dictionary
Set DictSum2 = New Scripting.Dictionary
'Store everything on your sheet into the array
arrData = ws.UsedRange.Value 'this will get from A1 till ctrl+end cell I'd delete rows and columns that are blank
'Loop through the array to fill the dictionary
For i = 2 To UBound(arrData) '2 because row 1 are headers, UBound is the function to get the last item of your array like .count
If arrData(i, 1) = vbNullString Then Exit For 'this will end the loop once finding an empty value on column A
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6) 'this is to work cleaner, each number is the number of the column concatenated
Sum1 = arrData(i, 7) 'column Sum 1
Sum2 = arrData(i, 8) 'column Sum 2
If Not DictSum1.Exists(ConcatenateStr) Then 'For the column Sum 1
DictSum1.Add ConcatenateStr, Sum1 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum1(ConcatenateStr) = DictSum1(ConcatenateStr) + Sum1 'this will sum the existing value on the dictionary + the current value of the loop
End If
If Not DictSum2.Exists(ConcatenateStr) Then 'For the column Sum 2
DictSum2.Add ConcatenateStr, Sum2 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum2(ConcatenateStr) = DictSum2(ConcatenateStr) + Sum2 'this will sum the existing value on the dictionary + the current value of the loop
End If
Next i
Erase arrData
With ws
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 6), Header:=xlYes 'Again UsedRange will take everything, Columns as you can see are the ones highlighted in yellow
arrData = .UsedRange.Value 'Store the results of deleting all the duplicates
For i = 2 To UBound(arrData) 'Lets fill the array with the sums
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6)
arrData(i, 8) = DictSum1(ConcatenateStr)
arrData(i, 9) = DictSum2(ConcatenateStr)
Next i
.UsedRange.Value = arrData 'Paste back the array with all the sums
End With
End Sub
我已经对代码进行了注释，但要了解更多有关词典的信息，请查看以下内容：
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim arrData As Variant
Dim i As Long, ConcatenateStr As String, Sum1 As Currency, Sum2 As Currency
Dim DictSum1 As Scripting.Dictionary 'You need the Microsoft Scripting Runtime reference for this to work
Dim DictSum2 As Scripting.Dictionary
Set ws = ThisWorkbook.Sheets("SheetName") 'Change this to fit your sheet name
Set DictSum1 = New Scripting.Dictionary 'This is how you initialize your dictionary
Set DictSum2 = New Scripting.Dictionary
'Store everything on your sheet into the array
arrData = ws.UsedRange.Value 'this will get from A1 till ctrl+end cell I'd delete rows and columns that are blank
'Loop through the array to fill the dictionary
For i = 2 To UBound(arrData) '2 because row 1 are headers, UBound is the function to get the last item of your array like .count
If arrData(i, 1) = vbNullString Then Exit For 'this will end the loop once finding an empty value on column A
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6) 'this is to work cleaner, each number is the number of the column concatenated
Sum1 = arrData(i, 7) 'column Sum 1
Sum2 = arrData(i, 8) 'column Sum 2
If Not DictSum1.Exists(ConcatenateStr) Then 'For the column Sum 1
DictSum1.Add ConcatenateStr, Sum1 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum1(ConcatenateStr) = DictSum1(ConcatenateStr) + Sum1 'this will sum the existing value on the dictionary + the current value of the loop
End If
If Not DictSum2.Exists(ConcatenateStr) Then 'For the column Sum 2
DictSum2.Add ConcatenateStr, Sum2 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum2(ConcatenateStr) = DictSum2(ConcatenateStr) + Sum2 'this will sum the existing value on the dictionary + the current value of the loop
End If
Next i
Erase arrData
With ws
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 6), Header:=xlYes 'Again UsedRange will take everything, Columns as you can see are the ones highlighted in yellow
arrData = .UsedRange.Value 'Store the results of deleting all the duplicates
For i = 2 To UBound(arrData) 'Lets fill the array with the sums
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6)
arrData(i, 8) = DictSum1(ConcatenateStr)
arrData(i, 9) = DictSum2(ConcatenateStr)
Next i
.UsedRange.Value = arrData 'Paste back the array with all the sums
End With
End Sub
我已经评论过代码，但是要了解字典的更多信息，请检查这个令人敬畏的
，您可能受益于阅读使用透视表的考虑。@ JSHIRANN，我需要使用VBA来做。谢谢大家!@Linga那么请在你的问题中更具体一些。你在哪里出错的？你的代码有什么问题？你在哪里遇到困难？只需发布您的代码并希望我们修复它就不太可能在堆栈溢出（参见）上工作。您可以从使用BIOT表的阅读中获益。@ JSEERAN，我需要使用VBA来做。谢谢大家!@Linga那么请在你的问题中更具体一些。你在哪里出错的？你的代码有什么问题？你在哪里遇到困难？仅仅发布您的代码并希望我们为您修复它不太可能在这里处理堆栈溢出（请参阅）。非常感谢！我在这里得到运行时错误9 arrData（i，9）=DictSum2（ConcatenateStr）。。我正在努力，会花时间的，哈哈！！这意味着DictSum2（ConcatenateStr）ConcatenateStrDictSum2（ConcatenateStr）ConcatenateStr