求助按条件取值求和的问题，谢谢

zhycl · 发表于 2018-6-19 11:42

本帖最后由 zhycl 于 2018-6-19 11:44 编辑

如附件示例，Sheet1表中的A、B两列为源数据，判断Sheet2表中的D列（中间有半角逗号隔开）单元格中含有Sheet1表中的A列数值，将Sheet1表中A列对应Sheet1表中B列的数值进行求和放置Sheet2表中E列中。非常感谢，函数或者VBA均可。

示例.rar (8.19 KB, 下载次数: 5)

lsdongjh · 发表于 2018-6-19 11:52

Sub Test()
Dim lngRows As Long
Dim arr As Variant
Dim objDic As Object, strTemp As String, strT() As String
Dim dblSUM As Double
lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
arr = Sheet1.Range("A1:B" & lngRows)
Set objDic = CreateObject("Scripting.Dictionary")
For lngRows = LBound(arr) To UBound(arr)
strTemp = arr(lngRows, 1)
objDic(strTemp) = arr(lngRows, 2)
Next
strTemp = Sheet1.Range("D1").Text
strT = Split(strTemp, ",")
For lngRows = LBound(strT) To UBound(strT)
dblSUM = dblSUM + objDic(strT(lngRows))
Next
Sheet1.Range("E1").Value = dblSUM
End Sub

复制代码

chxw68 · 发表于 2018-6-19 11:53

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:b" & r)
For i = 1 To UBound(arr)
d(CStr(arr(i, 1))) = arr(i, 2)
Next
End With
With Worksheets("sheet2")
xm = Split(.Range("d1"), ",")
s = 0
For i = 0 To UBound(xm)
If d.exists(xm(i)) Then
s = s + d(xm(i))
End If
Next
.Range("e1") = s
End With
End Sub

复制代码

chxw68 · 发表于 2018-6-19 11:54

详见附件。

lenghonghai601 · 发表于 2018-6-19 13:04

Sub 按钮1_Click()
Dim d As Object, s$, arr, brr, sum!
Set d = CreateObject("scripting.dictionary")
s = Range("d1").Value
arr = Split(s, ",")
brr = Sheet1.Range("a1").CurrentRegion
For i = 1 To UBound(brr)
d(brr(i, 1)) = brr(i, 2)
Next i
For i = 0 To UBound(arr)
sum = sum + d(Val(arr(i)))
Next i
Sheet2.Range("e1") = sum
End Sub

复制代码

zyf19890315 · 发表于 2018-6-19 13:27

Sub jisuan()
Dim arr As Variant

arr = VBA.Split(Sheet2.[d1], ",")
For i = 0 To UBound(arr)
  For Each Rng In Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
  If Rng = VBA.n(arr(i)) Then
  Sum = Sum + Rng.Offset(0, 1)
  End If

  Next
Next
Sheet2.[e1] = Sum
End Sub