求助！VBA多条件求和

宽一123

使用sumproduct函数特别慢，想用VBA实现，不知能否快一些。
折腾一天了，总是出错。请各路大侠帮帮忙。附有EXCEL表。

代号	初始库存	6-28	6-29	6-30	7-1	7-2	7-3	7-4	7-5	7-6
110202694	20
114300427	10
115801101	15
115801121	13
115801683	0
115801685	30
如何用VBA使空白区域等于初始库存-计划表里代号相同、日期相同的总数量。

宽一123

哪位大神帮忙回复下，在线等。

chis3

Sub test()
    Dim i As Integer, arr, dic As Object, brr(1 To 6, 1 To 13), j As Byte
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheets(2).[a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(arr(i, 1) & arr(i, 3)) = dic(arr(i, 1) & arr(i, 3)) + arr(i, 2)
    Next i
    arr = Sheets(1).[a1].CurrentRegion
    For i = 1 To UBound(brr)
        For j = 1 To UBound(brr, 2)
            brr(i, j) = dic(arr(i + 1, 1) & arr(1, j + 2))
        Next j
    Next i
    [c2].Resize(6, 13) = brr
    Set dic = Nothing
End Sub

hasyh2008

chis3 发表于 2018-7-22 19:31
Sub test()
    Dim i As Integer, arr, dic As Object, brr(1 To 6, 1 To 13), j As Byte
    Set dic = ...

高手啊，已收藏，学习中！！

sjlxp2010

Sub test()
    Dim i As Integer, arr, BRR(), dic As Object, dic1 As Object, j As Byte
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    arr = Sheets(2).[A1].CurrentRegion
    For i = 2 To UBound(arr)
      If arr(i, 1) <> "" Then
      dic1(arr(i, 1)) = ""
      End If
        dic(arr(i, 1) & arr(i, 3)) = dic(arr(i, 1) & arr(i, 3)) + arr(i, 2)
    Next i
    Key = dic1.KEYS
    Sheets(1).[A2].Resize(dic1.Count, 1) = WorksheetFunction.Transpose(Key)
    arr = Sheets(1).[A1].CurrentRegion
    L = Cells(1, Columns.Count).End(xlToLeft).Column
    ReDim BRR(1 To dic1.Count, 1 To L - 2)
    For i = 1 To UBound(BRR)
        For j = 1 To UBound(BRR, 2)
            BRR(i, j) = dic(arr(i + 1, 1) & arr(1, j + 2))
        Next j
    Next i
    [c2].Resize(UBound(BRR), L - 2) = BRR
    Set dic = Nothing
    [A1].CurrentRegion.EntireColumn.AutoFit
    [A1].CurrentRegion.Borders.LineStyle = xlContinuous
End Sub

wencycool

1. #coding=utf8
   
2. import sys
   
3. import xlwings
   
4. import time
   
5. def main():
   
6.     xlwings.App.visible = False
   
7.     filename = ur"计划.xlsx"
   
8.     wb = xlwings.Book(filename)
   
9.     plan_sht = wb.sheets(u"计划")
   
10.     frame_sht = wb.sheets(u"主表")
    
11.     plan_sht_max_row = plan_sht.range("A1000000").end("u").row
    
12.     plan_dict = {}
    
13.     for i in xrange(2, plan_sht_max_row):
    
14.         nbr, count, date = plan_sht.range("A%s:C%s" % (i, i)).value
    
15.         key = "~".join([nbr, str(date)])
    
16.         if plan_dict.has_key(key):
    
17.             plan_dict[key] = plan_dict[key] + count
    
18.         else:
    
19.             plan_dict[key] = count
    
20.     #print plan_dict
    
21.     frame_sht_max_col = frame_sht.range("A1").end("r").column + 1
    
22.     frame_sht_max_row = frame_sht.range("B1").end("d").row + 1
    
23.     for i in xrange(2, frame_sht_max_row):
    
24.         for j in xrange(3, frame_sht_max_col):
    
25.             #print frame_sht.cells(i, j).address
    
26.             date = frame_sht.cells(1, j).value
    
27.             nbr = frame_sht.cells(i, 1).value
    
28.             total = frame_sht.cells(i, 2).value
    
29.             key = "~".join([nbr, str(date)])
    
30.             if plan_dict.has_key(key):
    
31.                 frame_sht.cells(i, j).value = float(total) - float(plan_dict[key])
    
32.             else:
    
33.                 frame_sht.cells(i, j).value = total
    
34.     wb.save()
    
35.     wb.close()
    
36. 
    
37. if __name__ == "__main__":
    
38.     t1 = time.time()
    
39.     main()
    
40.     t2 = time.time()
    
41.     print(u"一共耗时：%s秒" % (t2 - t1))
    

复制代码

F:\tmp>python f:/tmp/test.py
一共耗时：4.78299999237秒

wencycool

1. #coding=utf8
   
2. import sys
   
3. import xlwings
   
4. import time
   
5. def main():
   
6.     xlwings.App.visible = False
   
7.     filename = ur"计划.xlsx"
   
8.     wb = xlwings.Book(filename)
   
9.     plan_sht = wb.sheets(u"计划")
   
10.     frame_sht = wb.sheets(u"主表")
    
11.     plan_sht_max_row = plan_sht.range("A1000000").end("u").row
    
12.     plan_dict = {}
    
13.     for i in xrange(2, plan_sht_max_row):
    
14.         nbr, count, date = plan_sht.range("A%s:C%s" % (i, i)).value
    
15.         key = "~".join([nbr, str(date)])
    
16.         if plan_dict.has_key(key):
    
17.             plan_dict[key] = plan_dict[key] + count
    
18.         else:
    
19.             plan_dict[key] = count
    
20.     #print plan_dict
    
21.     frame_sht_max_col = frame_sht.range("A1").end("r").column + 1
    
22.     frame_sht_max_row = frame_sht.range("B1").end("d").row + 1
    
23.     for i in xrange(2, frame_sht_max_row):
    
24.         for j in xrange(3, frame_sht_max_col):
    
25.             #print frame_sht.cells(i, j).address
    
26.             date = frame_sht.cells(1, j).value
    
27.             nbr = frame_sht.cells(i, 1).value
    
28.             total = frame_sht.cells(i, 2).value
    
29.             key = "~".join([nbr, str(date)])
    
30.             if plan_dict.has_key(key):
    
31.                 frame_sht.cells(i, j).value = float(total) - float(plan_dict[key])
    
32.             else:
    
33.                 frame_sht.cells(i, j).value = total
    
34.     wb.save()
    
35.     wb.close()
    
36. 
    
37. if __name__ == "__main__":
    
38.     t1 = time.time()
    
39.     main()
    
40.     t2 = time.time()
    
41.     print(u"一共耗时：%s秒" % (t2 - t1))
    

复制代码

F:\tmp>python f:/tmp/test.py
一共耗时：4.78299999237秒

lsc900707

宽一123 发表于 2018-7-22 18:15
哪位大神帮忙回复下，在线等。

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         s = arr(i, 1) & arr(i, 3)
   
6.         d(s) = d(s) + arr(i, 2)
   
7.     Next
   
8.     brr = [a1].CurrentRegion
   
9.     For i = 2 To UBound(brr)
   
10.         For j = 3 To UBound(brr, 2)
    
11.             s = brr(i, 1) & brr(1, j)
    
12.             If d.exists(s) Then brr(i, j) = d(s)
    
13.         Next
    
14.     Next
    
15.     [a1].CurrentRegion = brr
    
16.     Set d = Nothing
    
17. End Sub

复制代码

lsc900707

附件供测试：

宽一123

chis3 发表于 2018-7-22 19:31
Sub test()
    Dim i As Integer, arr, dic As Object, brr(1 To 6, 1 To 13), j As Byte
    Set dic = ...

谢谢 你们都好厉害！