[已解决]满足多条件汇总

lidayu

grf1973 发表于 2016-1-21 14:02
见15楼附件。

grf1973 您好，再请教您下，就是满足多条件汇总工作簿中的代码如果放在“模块”中要修改？ 在其它代码运行时调用（call 小单位数量汇总）“小单位数量汇总的代码”,要怎么才不会提示出错，我用二级有效数据下拉调用时运行到这：arr = Sheets("数据源").[a1].CurrentRegion 错误。
请您赐教，谢谢！

grf1973

代码已放入模块中。
回答你那个问题：
看看工作表“数据源”是否存在？或者把arr = Sheets("数据源").[a1].CurrentRegion  改为 arr = Sheets(1).[a1].CurrentRegion ，需要把数据源表放到第一张工作表位置。

lidayu

grf1973 发表于 2016-1-25 11:24
代码已放入模块中。
回答你那个问题：
看看工作表“数据源”是否存在？或者把arr = Sheets("数据源").[a1 ...

grf1973 您好，我的意思是直接用二级下拉调用“Call 小单位数量汇总”要怎么修改。
工作表代码：
'Private Sub Worksheet_Change(ByVal Target As Range)
'    If Intersect(Target, [a2:a3]) Is Nothing Then Exit Sub
'    Application.EnableEvents = False
'    If Target.Address = "$A$2" Then 'Exit Sub
'        [a3] = ""
'        [c4:J13] = ""
'    ElseIf Target.Address = "$A$3" Then 'Exit Sub
'
'        Call 小单位数量汇总
'    End If
'    Application.EnableEvents = True
'End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [a2:a3]) Is Nothing Then Exit Sub
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据源").[a1].CurrentRegion
    For i = 2 To UBound(arr)
        x = arr(i, 3)
        If InStr(d(x), arr(i, 4)) = 0 Then d(x) = d(x) & "," & arr(i, 4)
    Next
    If Target.Address = "$A$2" Then k = Join(d.keys, ",") Else k = Mid(d(Range("a2").Value), 2)
    With Target.Validation
        .Delete
        .Add xlValidateList, , , k
    End With
   Call 小单位数量汇总
End Sub
上面红色代码不用的话能实现吗？

模块代码：
Sub 小单位数量汇总()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据源").[a1].CurrentRegion
    For i = 2 To UBound(arr)
        x = arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 2) & "软肩章" & arr(i, 6)     '大单位+小单位+级别+性别+软肩章号
        y = arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 2) & "套肩章" & arr(i, 7)     '大单位+小单位+级别+性别+套肩章号
        d(x) = d(x) + arr(i, 1)
        d(y) = d(y) + arr(i, 1)
    Next
    [c4:J13] = ""
    arr = [a2:J13]
    For i = 3 To UBound(arr) - 2
        If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
        For j = 3 To 7
            If arr(1, j) = "" Then arr(1, j) = arr(1, j - 1)
            x = [a2] & [a3] & arr(i, 1) & arr(i, 2) & arr(1, j) & arr(2, j)   '大单位+小单位+级别+性别+软（套）肩章号
            arr(i, j) = d(x)
            arr(11, j) = arr(11, j) + arr(i, j)   '第12行汇总
            arr(12, 3) = arr(12, 3) + arr(i, j)        '第13行总计
        Next
        arr(i, 8) = arr(i, 3) + arr(i, 4) + arr(i, 5)
        arr(i, 9) = arr(i, 6) + arr(i, 7)
        arr(i, 10) = arr(i, 8) + arr(i, 9)
        arr(11, 8) = arr(11, 8) + arr(i, 8)
        arr(11, 9) = arr(11, 9) + arr(i, 9)
    Next
    [a2:J13] = arr
End Sub

grf1973

不能，应该是单元格改变后调用sub（Worksheet_Change事件调用）。
下面黑色的Worksheet_SelectionChange事件是鼠标选中单元格触发的事件。本例中仅对A2：A3生成有效性。

lidayu

grf1973 发表于 2016-1-20 16:28
灰色区域VBA实现已完成。
另外：“数据源A列的姓名（是计数）如果改为数量（2、8、求和）代码要怎么修改？ ...

grf1973您好，碰到一个新问题请您赐教，下面代码要怎么改为三级下拉（A2一级，A3二级，A4三级）数据来源“sheet1”A列一级，B列二级，C列三级，附图片如下：

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Intersect(Target, [a2:a3]) Is Nothing Then Exit Sub
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Arr = Sheets("sheet1").[a1].CurrentRegion
   
5.     For i = 2 To UBound(Arr)
   
6.         x = Arr(i, 1)
   
7.         If InStr(d(x), Arr(i, 2)) = 0 Then d(x) = d(x) & "," & Arr(i, 2)
   
8.     Next
   
9.     If Target.Address = "$A$2" Then k = Join(d.keys, ",") Else k = Mid(d(Range("a2").Value), 2)
   
10.     With Target.Validation
    
11.         .Delete
    
12.         .Add xlValidateList, , , k
    
13.     End With
    
14. End Sub

复制代码

谢谢您多次帮助。

grf1973

以前做过的一个例子，自己改改就行了。

lidayu

grf1973 发表于 2016-3-30 09:22
以前做过的一个例子，自己改改就行了。

grf1973 您好，您这工作簿是列形式的我想要的单元格，所以我不懂怎么改，请您帮忙改下好吗谢谢！
呈上附件： 二级改为三级.rar (516.61 KB, 下载次数: 4)

2016-3-30 10:00 上传

点击文件名下载附件

grf1973

在原帖也回了。

lidayu

grf1973 发表于 2016-1-20 14:28

grf1973 您好，上次您帮我计数汇总现在改为“√”要怎么修改才能实现，附件中有您之前的代码，希望能再一次得到您的帮助，谢谢！
VBA满足多条件汇总√.rar (93.87 KB, 下载次数: 3)

2016-3-31 11:45 上传

点击文件名下载附件

grf1973

请看附件。