[已解决]用VBA实现筛选和多条件求和

tubing78

如题，想实现以下想法，请热心的大神帮忙，急用！先谢了
1、清除统计工作表中A4以下的数据，筛选明细工作表B列中在统计工作表B1到D1的时间段内有记录的单位写入A4以下的单元格
2、实现统计工作表B4:B224  C3：D224现有公式的功能，C列和D列的公式稍有不同（特别是SUMPRODUCT公式，SUMPRODUCT公式多了拖的表很慢，在明细表的相关单元格里输入一次数据要等5秒左右，只能关闭自动计算才行，但表里有些单元格要自动计算看结果）
3、大神们如果有空，再顺便帮忙看一下现有的拼音检索录入的代码有什么问题没，优化一下（是直接用别人的代码改的），能不能在明细表B列输入那个单位就按照名称表B:C的对应该关系在D列中输入相应的数据，现在是用VLOOKUP公式实现的，我怕公式多了表变慢


我是小白，一时半会也琢磨不会VBA，但又着急用，恳求 大神帮助！！ 流水.zip (49.89 KB, 下载次数: 24)

2014-5-4 13:41 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-5-4 14:31

请看附件。

跳转到最佳答案楼层

grf1973

1. Sub 按条件筛选()
   
2.     r = Sheet1.[b65536].End(3).Row
   
3.     arr = Sheet1.Range("A1:L" & r)
   
4.     ReDim brr(1 To UBound(arr), 1 To 4)
   
5.     sday = Sheet3.[b1]: eday = Sheet3.[d1]
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For i = 2 To UBound(arr)
   
8.         xkey = arr(i, 2)
   
9.         rq = arr(i, 1)
   
10.         If Len(xkey) > 0 Then
    
11.             If Not d.exists(xkey) Then
    
12.                 k = k + 1
    
13.                 d(xkey) = k
    
14.                 brr(k, 1) = xkey
    
15.                 brr(k, 2) = arr(i, 4)
    
16.             End If
    
17.             p = d(xkey)
    
18.             If rq <= eday Then brr(p, 3) = brr(p, 3) + Val(arr(i, 11))
    
19.             If rq <= eday And rq >= sday Then brr(p, 4) = brr(p, 4) + Val(arr(i, 12))
    
20.         End If
    
21.     Next
    
22.     With Sheet3
    
23.         .Range("a4:d10000").ClearContents
    
24.         .[a4].Resize(k, 4) = brr
    
25.     End With
    
26. End Sub
    

复制代码

grf1973

请看附件。

tubing78

grf1973 发表于 2014-5-4 14:31
请看附件。

谢谢grf1973

能不能帮我看一下 明细表中的代码，让B列输入数据的同时，按照名称表中B:C的对应关系 在明细表的D列输入相应的区域

再次感谢！

grf1973

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim xrng As Range
   
3.     If Target.Column <> 2 Or Target.Row = 1 Then Exit Sub
   
4.     Set xrng = Sheet4.Range("b:b").Find(Target, lookat:=xlWhole)
   
5.     If Not xrng Is Nothing Then Target.Offset(0, 2) = xrng.Offset(0, 1)
   
6. End Sub

复制代码

grf1973

请看附件。搞不清你里面Listbox,Textbox操作后的情况。如果B列只用有效性选择出来，那么D列可以正常显示，如果B列是通过Listbox筛选出来的，D列没有反应。你可以试试。

tubing78

grf1973 发表于 2014-5-4 14:52
请看附件。搞不清你里面Listbox,Textbox操作后的情况。如果B列只用有效性选择出来，那么D列可以正常显示，如 ...

还得麻烦你，回到第一个问题，我要统计出的是在那个日期区间里有交易的单位，现在的代码，是把所有有交易的都筛选出来了，其实也可以，担心以后数据多了，空的会很多{:1712:}

tubing78

grf1973 发表于 2014-5-4 14:52
请看附件。搞不清你里面Listbox,Textbox操作后的情况。如果B列只用有效性选择出来，那么D列可以正常显示，如 ...

其实有效性验证的完全可以取消了，要通过Listbox输入的实现，

代码是我搬别人的  你不知道是什么作用的我更不知道，嘿嘿

grf1973

1.     r = Sheet1.[b65536].End(3).Row
   
2.     arr = Sheet1.Range("A1:L" & r)
   
3.     ReDim brr(1 To UBound(arr), 1 To 4)
   
4.     sday = Sheet3.[b1]: eday = Sheet3.[d1]
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.         xkey = arr(i, 2)
   
8.         rq = arr(i, 1)
   
9.         If Len(xkey) > 0 Then
   
10.             If Not d.exists(xkey) Then
    
11.                 k = k + 1
    
12.                 d(xkey) = k
    
13.                 brr(k, 1) = xkey
    
14.                 brr(k, 2) = arr(i, 4)
    
15.             End If
    
16.             p = d(xkey)
    
17.             If rq <= eday Then brr(p, 3) = brr(p, 3) + Val(arr(i, 11))
    
18.             If rq <= eday And rq >= sday Then brr(p, 4) = brr(p, 4) + Val(arr(i, 12))
    
19.         End If
    
20.     Next
    
21.     ReDim crr(1 To k, 1 To 4)
    
22.     For i = 1 To k
    
23.         If brr(i, 3) > 0 Or brr(i, 4) > 0 Then
    
24.             n = n + 1
    
25.             crr(n, 1) = brr(i, 1): crr(n, 2) = brr(i, 2): crr(n, 3) = brr(i, 3): crr(n, 4) = brr(i, 4)
    
26.         End If
    
27.     Next
    
28.     With Sheet3
    
29.         .Range("a4:d10000").ClearContents
    
30.         .[a4].Resize(n, 4) = crr
    
31.     End With
    
32. End Sub

复制代码

多用个数组crr，把brr里非空的筛选出来。

grf1973

请看附件。把前面自动显示D列的问题也解决了。原来ListBox的KeyDown事件中多了句 Application.EnableEvents = False，去掉就OK了。