求助有竖列和横列多个条件的求和

zhangcheng6688

借楼学习一下字典，打扰了
Sub test()
arr = Sheets("预算").[a1].CurrentRegion
With Sheets("分析")
   yf = .[d2]
   brr = .[a4].CurrentRegion
End With
ReDim crr(1 To UBound(brr), 1 To 1)
Set dic = CreateObject("scripting.dictionary")
For i = 5 To UBound(arr, 2) - 1
   If arr(1, i) = yf Then
      For j = 2 To UBound(arr)
         If Not dic.exists(arr(j, 2)) Then
            Set dic(arr(j, 2)) = CreateObject("scripting.dictionary")
         End If
         dic(arr(j, 2))(arr(j, 3)) = dic(arr(j, 2))(arr(j, 3)) + arr(j, i)
      Next
   End If
Next
For i = 2 To UBound(brr) - 1
   If brr(i, 1) = "" Then
      brr(i, 1) = brr(i - 1, 1)
   End If
   m = m + 1
   If dic.exists(brr(i, 1)) Then
      If dic(brr(i, 1)).exists(brr(i, 2)) Then
         crr(m, 1) = dic(brr(i, 1))(brr(i, 2))
      End If
      xj = xj + crr(m, 1)
   End If
Next
If m > 0 Then
   m = m + 1
   crr(m, 1) = xj
   Sheets("分析").[d5].Resize(m, 1) = crr
End If
Set dic = Nothing
End Sub