[已解决]VBA信息调用问题

龙送农

通过单元格D3选择单位，不用点击按钮，直接调出所要信息（里面的代码调出信息不准确）[size=14.6667px]。当D3选择单位是“全县”时，调出所有信息。
fjmxwrs老师的解答：
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$2" Then
        Dim arr, str1$, brr(), x%, i%, y%, r%
        With Sheet1
            r = .Range("B65536").End(xlUp).Row
            arr = .Range("A5:AU" & r)
        End With
        str1 = Target.Value
        If str1 = "全部" Then
            For x = 1 To UBound(arr)
                i = i + 1
                ReDim Preserve brr(1 To 31, 1 To i)
                brr(1, i) = i
                For y = 2 To 6
                    brr(y, i) = arr(x, y)
                Next y
                For y = 8 To 11
                    brr(y - 1, i) = arr(x, y)
                Next y
                brr(11, i) = arr(x, 13)
                brr(12, i) = arr(x, 15)
                For y = 17 To 26
                    brr(y - 4, i) = arr(x, y)
                Next y
                For y = 30 To 37
                    brr(y - 7, i) = arr(x, y)
                Next y
                brr(31, i) = arr(x, 47)
            Next x
        Else
            For x = 1 To UBound(arr)
                If arr(x, 3) = str1 Then
                    i = i + 1
                    ReDim Preserve brr(1 To 31, 1 To i)
                    brr(1, i) = i
                    For y = 2 To 6
                        brr(y, i) = arr(x, y)
                    Next y
                    For y = 8 To 11
                        brr(y - 1, i) = arr(x, y)
                    Next y
                    brr(11, i) = arr(x, 13)
                    brr(12, i) = arr(x, 15)
                    For y = 17 To 26
                        brr(y - 4, i) = arr(x, y)
                    Next y
                    For y = 30 To 37
                        brr(y - 7, i) = arr(x, y)
                    Next y
                    brr(31, i) = arr(x, 47)
                End If
            Next x
        End If
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Range("A5:AE10000").ClearContents
        Range("A5").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
        Erase arr, brr
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$D$2:$H$2" Then
        Dim d As Object, arr, x%, str1$
        Set d = CreateObject("scripting.dictionary")
        With Sheet1
            r = .Range("B65536").End(xlUp).Row
            arr = .Range("A5:AU" & r)
        End With
        For x = 1 To UBound(arr)
            d(arr(x, 3)) = ""
        Next x
        str1 = Join(d.keys, ",") & ",全部"
        With Target.Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:=str1
        End With
        d.RemoveAll
        Erase arr
    End If
End Sub

最佳答案

月排行榜 / 总排行榜

02761752696

2016-6-8 21:10

龙送农 发表于 2016-6-8 19:39
老师：麻烦您帮再修改代码，如果一个单位人员名单在“数据库”不连续时，出现图片这样情况。

这是你的原代码的问题，之前没注意

跳转到最佳答案楼层

yannoble

新人报道，新人报道

02761752696

．．．．．．．．．．．．这样吗[url=]删除[/url]

龙送农

02761752696 发表于 2016-6-8 17:29
．．．．．．．．．．．．这样吗

老师：麻烦您帮再修改代码，如果一个单位人员名单在“数据库”不连续时，出现图片这样情况。

fjmxwrs

全部用单元格事件完成的，选择D2单元格时，自动以数据库表的单位建立数据有效性带下拉(单位有多少就建立多少)
选择单位时，提取数据(数据库中的人员单位可以乱序)
请看效果

02761752696

龙送农 发表于 2016-6-8 19:39
老师：麻烦您帮再修改代码，如果一个单位人员名单在“数据库”不连续时，出现图片这样情况。

这是你的原代码的问题，之前没注意

龙送农

谢谢02761752696和fjmxwrs两位老师解答，效果均达到，再次感谢两位老师！！设佳更纠结，因为02761752696先参与讨论，对不起fjmxwrs老师了！！！！

fjmxwrs

龙送农 发表于 2016-6-8 22:05
谢谢02761752696和fjmxwrs两位老师解答，效果均达到，再次感谢两位老师！！设佳更纠结，因为02761752696先参 ...

无需纠结，读懂代码的意思才是关键，对学习有帮助即可

龙送农

02761752696 发表于 2016-6-8 21:10
这是你的原代码的问题，之前没注意

查找出来是同一人信息去了，再麻烦老师看看.

02761752696

龙送农 发表于 2016-6-8 22:47
查找出来是同一人信息去了，再麻烦老师看看.

什么意思？？？