VBA/Excel - 如果相邻单元格的值匹配，则添加单元格值

Question

我正在使用一个电子表格来跟踪全球各种存储位置的每月风险值。

我的表格有三列，每个单独的存储位置都有一个单独的行，详细说明 A 列：月份（四月、五月或六月） B 列：存储设施的位置（国家/地区） C 列：存储位置的每月风险值

我的任务是计算上述每个月每个国家/地区的存储位置总值的平均风险值。 大约有 12000 个存储位置分布在 75 个左右的国家/地区，因此我希望实现自动化。

我实际上需要一些等效于“如果相邻单元格 2A（月）和 2B（国家/地区）中的值与相邻单元格 1A 和 1B 中的值匹配[确定相应的风险值是针对同一月份/国家/地区的某个位置]，然后将单元格 2C 中的值与单元格 1C 中的值相加；如果不是，则使用当前单元格 2C 中的值”。 该表按月/国家/地区过滤，因此如果相邻单元格不匹配，则公式应返回单元格 2C 中的值，因为这意味着我们现在正在查看下个月/国家/地区的数据，然后从 0 再次聚合。

我绝不是在找人为我写这个，但如果有人能指出我可以为此工作的函数/VBA工具的方向，那将不胜感激。

谢谢！

Answer 1

请尝试下一个代码。 它需要对“Microsoft Scripting runtime”的引用。 我还将发布一段代码，能够自动添加它：

Sub sumUniqueConcatenatedCases()
  Dim sh As Worksheet, sh1 As Worksheet, lastR As Long
  Dim arr, arrFin, arrKey, i As Long, dict As New Scripting.Dictionary
  
  Set sh = ActiveSheet
  Set sh1 = sh.Next 'you can use here a sheet you need (to return the procesed data)
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row    'last row of A:A column
  arr = sh.Range("A2:C" & lastR).Value                   'place the range in an array for faster iteration
  For i = 1 To UBound(arr)                               'iterate between the array elements
    If Not dict.Exists(arr(i, 1) & "|" & arr(i, 2)) Then 'if not in dictionary:
        dict.Add arr(i, 1) & "|" & arr(i, 2), arr(i, 3)  'create the key with value from C:C as item
    Else
        dict(arr(i, 1) & "|" & arr(i, 2)) = dict(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3) 'add C:C value to existing item value
    End If
  Next i
 
  ReDim arrFin(1 To dict.count, 1 To 3)  'reDim the final array in order to keep the dictionary keys and necessary values
  'Place the processed values in final array (arrFin):
  For i = 0 To dict.count - 1
        arrKey = Split(dict.Keys(i), "|")  'split the key, to extract the first two columns strings
        arrFin(i + 1, 1) = arrKey(0): arrFin(i + 1, 2) = arrKey(1) 'place the extracted strings in arrFin
        arrFin(i + 1, 3) = dict.items(i)   'place the item in the third column
  Next
  'drop the processed array result (in the next sheete) at once:
  sh1.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
  MsgBox "Ready..."
End Sub

它将在下一个工作表中返回处理结果。 如果下一张不方便，退货单应该很容易适应您的需要。 但是，这样的下一个工作表必须存在......要自动添加必要的引用，请运行下一个代码：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  On Error Resume Next
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
  If err.Number = 32813 Then
        err.Clear: On Error GoTo 0
        MsgBox "The reference already exists...": Exit Sub
  Else
        On Error GoTo 0
        MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
  End If
End Sub

运行此代码，保存工作簿（为将来保留参考），然后才运行上述工作簿。

代码可以设计为不需要这样的参考，但最好有智能感知建议，什么时候尝试使用自己的字典。

请测试它并发送一些反馈。

而且，请注意，下次提出问题时，您应该证明您至少做过研究。 最好的方法是向我们展示一段代码，即使它没有做你需要的......