[已解决]查找引用，并相乘求和

jordanlive

增加了点难度的表格，自己的水平有限。求帮助

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-4 15:28

Sub tiqu()
  Dim D1, D2, D3, X%, Y%, Summ
  Dim Arr, Brr
  Set D1 = CreateObject("scripting.dictionary")
  Set D2 = CreateObject("scripting.dictionary")
  Set D3 = CreateObject("scripting.dictionary")
  Arr = Sheet1.Range("A1").CurrentRegion
  Brr = Sheet2.Range("A1").CurrentRegion
  Y = Application.WorksheetFunction.Match(Sheet2.Range("L2"), Sheet1.Range("A1:I1"), 0)
  For X = 2 To UBound(Arr)
    D1(Arr(X, 3) & Arr(X, 4)) = Arr(X, 2)
    D2(Arr(X, 3) & Arr(X, 4)) = Arr(X, 5)
    D3(Arr(X, 3) & Arr(X, 4)) = Arr(X, Y)
  Next X
  For X = 2 To UBound(Brr)
    Brr(X, 1) = X - 1
    Brr(X, 2) = D1(Brr(X, 3) & Brr(X, 4))
    Brr(X, 5) = D2(Brr(X, 3) & Brr(X, 4))
    Brr(X, 8) = D3(Brr(X, 3) & Brr(X, 4)) * Brr(X, 6)
    Summ = Summ + Brr(X, 8)
  Next X
  Sheet2.Range("A1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
  Sheet2.Range("K2") = Summ
End Sub

跳转到最佳答案楼层

hasyh2008

Sub tiqu()
  Dim D1, D2, D3, X%, Y%, Summ
  Dim Arr, Brr
  Set D1 = CreateObject("scripting.dictionary")
  Set D2 = CreateObject("scripting.dictionary")
  Set D3 = CreateObject("scripting.dictionary")
  Arr = Sheet1.Range("A1").CurrentRegion
  Brr = Sheet2.Range("A1").CurrentRegion
  Y = Application.WorksheetFunction.Match(Sheet2.Range("L2"), Sheet1.Range("A1:I1"), 0)
  For X = 2 To UBound(Arr)
    D1(Arr(X, 3) & Arr(X, 4)) = Arr(X, 2)
    D2(Arr(X, 3) & Arr(X, 4)) = Arr(X, 5)
    D3(Arr(X, 3) & Arr(X, 4)) = Arr(X, Y)
  Next X
  For X = 2 To UBound(Brr)
    Brr(X, 1) = X - 1
    Brr(X, 2) = D1(Brr(X, 3) & Brr(X, 4))
    Brr(X, 5) = D2(Brr(X, 3) & Brr(X, 4))
    Brr(X, 8) = D3(Brr(X, 3) & Brr(X, 4)) * Brr(X, 6)
    Summ = Summ + Brr(X, 8)
  Next X
  Sheet2.Range("A1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
  Sheet2.Range("K2") = Summ
End Sub