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

Question

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

我的表格有三列，每个单独的存储位置都有单独的行详细说明 A 列：月份（4 月、5 月或 6 月） B 栏：储存设施的位置（国家） C 列：存储地点的月度风险值

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

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

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

谢谢！

Answer 1

请尝试下一个代码。它需要对“Microsoft 脚本运行时”的引用。我也贴一段代码，可以自动添加：

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

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

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

请进行测试并发送一些反馈。

并且，请注意，下次提问时，您应该证明您至少做过研究。最好的方法是向我们展示一段代码，即使它不能满足您的需求......