三级下拉菜单让死表变活

liulang0808

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.      If Application.Intersect(Target, [b3:c5]) Is Nothing Then Exit Sub
   
3.      Set ds = CreateObject("scripting.dictionary")
   
4.      Set dj = CreateObject("scripting.dictionary")
   
5.      crr = [a6:o13]
   
6.     arr = Sheets("销售数据源").[a1].CurrentRegion
   
7.     For j = 2 To UBound(arr)
   
8.         If arr(j, 4) = [b3] And InStr(arr(j, 5), [b4]) > 0 And InStr(arr(j, 6), [b5]) > 0 Then
   
9.             ds(arr(j, 1) & arr(j, 7)) = ds(arr(j, 1) & arr(j, 7)) + arr(j, 9)
   
10.             dj(arr(j, 1) & arr(j, 7)) = dj(arr(j, 1) & arr(j, 7)) + arr(j, 10)
    
11.         End If
    
12.     Next j
    
13.     arr = Sheets("库存数据源").[a1].CurrentRegion
    
14.     For j = 2 To UBound(arr)
    
15.         If arr(j, 4) = [b3] And InStr(arr(j, 5), [b4]) > 0 And InStr(arr(j, 6), [b5]) > 0 Then
    
16.             ds(arr(j, 1) & arr(j, 7)) = ds(arr(j, 1) & arr(j, 7)) + arr(j, 9)
    
17.             dj(arr(j, 1) & arr(j, 7)) = dj(arr(j, 1) & arr(j, 7)) + arr(j, 10)
    
18.         End If
    
19.     Next j
    
20.     For j = 3 To UBound(crr)
    
21.         sm = 0
    
22.         jm = 0
    
23.         For i = 2 To 7
    
24.             
    
25.             If ds.exists(crr(j, 1) & crr(2, i)) Then
    
26.                 crr(j, i) = ds(crr(j, 1) & crr(2, i))
    
27.                 crr(j, i + 7) = dj(crr(j, 1) & crr(2, i))
    
28.             Else
    
29.                 crr(j, i) = 0
    
30.                 crr(j, i + 7) = 0
    
31.             End If
    
32.             sm = crr(j, i) + sm
    
33.             jm = crr(j, i + 7) + jm
    
34.         Next i
    
35.         
    
36.         crr(j, 8) = sm
    
37.         crr(j, 15) = jm
    
38.         
    
39.     Next j
    
40.     For j = 2 To UBound(crr, 2)
    
41.         crr(5, j) = crr(4, j) + crr(3, j)
    
42.         crr(8, j) = crr(6, j) + crr(7, j)
    
43.     Next j
    
44.     [a6:o13] = crr
    
45. End Sub
    
46. 
    
47. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '三级下拉菜单
    
48.     On Error Resume Next
    
49.     If Target.Address <> "$B$3:$C$3" And Target.Address <> "$B$4:$C$4" And Target.Address <> "$B$5:$C$5" Then Exit Sub
    
50.     Dim arr, d As Object, i&, x$
    
51.     Set d = CreateObject("scripting.dictionary")
    
52.     arr = Sheets("销售数据源").[a1].CurrentRegion
    
53.     For i = 2 To UBound(arr)
    
54.         x = arr(i, 4)
    
55.         If Not d.exists(x) Then
    
56.             Set d(x) = CreateObject("Scripting.Dictionary")
    
57.             d(x)(arr(i, 5) & "") = arr(i, 6)
    
58.         ElseIf InStr("," & d(x)(arr(i, 5) & "") & ",", "," & arr(i, 6) & ",") = 0 Then
    
59.             d(x)(arr(i, 5) & "") = d(x)(arr(i, 5) & "") & "," & arr(i, 6)
    
60.         End If
    
61.     Next
    
62. '    Sheet11.Unprotect
    
63.     With Target.Validation
    
64.         .Delete
    
65.         Select Case Target.Address
    
66.             Case "$B$3:$C$3"
    
67.                 .Add xlValidateList, , , Join(d.keys, ",")
    
68.                 [b4:b5] = ""
    
69.             Case "$B$4:$C$4"
    
70.                 .Add xlValidateList, , , Join(d([b3].Value).keys, ",")
    
71.                 [b5] = ""
    
72.             Case "$B$5:$C$5"
    
73.                 .Add xlValidateList, , , d([b3].Value)([b4].Value)
    
74.         End Select
    
75.     End With
    
76. '    Sheet11.Protect UserInterfaceOnly:=True
    
77. End Sub

复制代码

liulang0808

增加了另外一个事件，用于统计数量，楼主这次看看是不是这个需求吧

学习再进步

liulang0808 发表于 2018-11-30 21:20
增加了另外一个事件，用于统计数量，楼主这次看看是不是这个需求吧

是！就是这样的，谢谢您了！

学习再进步

学习再进步 发表于 2018-12-1 09:40
是！就是这样的，谢谢您了！

你没有把A2:F2R的起止时间作为一个条件

jevenjiang

学习再进步 发表于 2018-12-1 09:44
你没有把A2:F2R的起止时间作为一个条件

用这个替换原来那代码，增加了日期条件。


Private Sub Worksheet_Change(ByVal Target As Range)
     If Application.Intersect(Target, [c2,f2,b3:c5]) Is Nothing Then Exit Sub
     Set ds = CreateObject("scripting.dictionary")
     Set dj = CreateObject("scripting.dictionary")
     crr = [a6:o13]
    arr = Sheets("销售数据源").[a1].CurrentRegion
    For j = 2 To UBound(arr)
        If arr(j, 2) >= [c2] And arr(j, 2) <= [f2] And arr(j, 4) = [b3] And InStr(arr(j, 5), [b4]) > 0 And InStr(arr(j, 6), [b5]) > 0 Then
            ds(arr(j, 1) & arr(j, 7)) = ds(arr(j, 1) & arr(j, 7)) + arr(j, 9)
            dj(arr(j, 1) & arr(j, 7)) = dj(arr(j, 1) & arr(j, 7)) + arr(j, 10)
        End If
    Next j
    arr = Sheets("库存数据源").[a1].CurrentRegion
    For j = 2 To UBound(arr)
        If arr(j, 2) >= [c2] And arr(j, 2) <= [f2] And arr(j, 4) = [b3] And InStr(arr(j, 5), [b4]) > 0 And InStr(arr(j, 6), [b5]) > 0 Then
            ds(arr(j, 1) & arr(j, 7)) = ds(arr(j, 1) & arr(j, 7)) + arr(j, 9)
            dj(arr(j, 1) & arr(j, 7)) = dj(arr(j, 1) & arr(j, 7)) + arr(j, 10)
        End If
    Next j
    For j = 3 To UBound(crr)
        sm = 0
        jm = 0
        For i = 2 To 7
            
            If ds.exists(crr(j, 1) & crr(2, i)) Then
                crr(j, i) = ds(crr(j, 1) & crr(2, i))
                crr(j, i + 7) = dj(crr(j, 1) & crr(2, i))
            Else
                crr(j, i) = 0
                crr(j, i + 7) = 0
            End If
            sm = crr(j, i) + sm
            jm = crr(j, i + 7) + jm
        Next i
        
        crr(j, 8) = sm
        crr(j, 15) = jm
        
    Next j
    For j = 2 To UBound(crr, 2)
        crr(5, j) = crr(4, j) + crr(3, j)
        crr(8, j) = crr(6, j) + crr(7, j)
    Next j
    [a6:o13] = crr
End Sub

学习再进步

大师！能把我这个表解决吗？是跨文件夹的，代码写在查询表，

学习再进步

jevenjiang 发表于 2018-12-1 13:10
用这个替换原来那代码，增加了日期条件。

大师！能把我下面的表解决吗？

学习再进步

liulang0808 发表于 2018-11-30 21:20
增加了另外一个事件，用于统计数量，楼主这次看看是不是这个需求吧

大师，能帮我解决下面的表吗？有一个案例

sgh-8

收藏学习！！

洋务德雷

如果是Office，使用SQL是最好的解决方案。