[已解决]VBA查询名单

龙送农

这是fjmxwrs老师写的代码：

1、怎样调整代码，使信息往前一列调整；

2、序号的代码是那句，麻烦您帮标出来。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$F$2" Then
        Dim arr, str1$, brr(), x%, i%, y%, r%
        With Sheet1
            r = .Range("B65536").End(xlUp).Row
            arr = .Range("A5:BG" & 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 = 3 To 7
                    brr(y, i) = arr(x, y)
                Next y
                For y = 9 To 12
                    brr(y - 1, i) = arr(x, y)
                Next y
                brr(11, i) = arr(x, 14)
                brr(12, i) = arr(x, 16)
                For y = 18 To 27
                    brr(y - 4, i) = arr(x, y)
                Next y
                For y = 31 To 38
                    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, 4) = str1 Then
                    i = i + 1
                    ReDim Preserve brr(1 To 31, 1 To i)
                    brr(1, i) = i
                    For y = 3 To 7
                        brr(y, i) = arr(x, y)
                    Next y
                    For y = 9 To 12
                        brr(y - 1, i) = arr(x, y)
                    Next y
                    brr(11, i) = arr(x, 14)
                    brr(12, i) = arr(x, 16)
                    For y = 18 To 27
                        brr(y - 4, i) = arr(x, y)
                    Next y
                    For y = 31 To 38
                        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 = "$F$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:BG" & r)
        End With
        For x = 1 To UBound(arr)
            d(arr(x, 4)) = ""
        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

最佳答案

月排行榜 / 总排行榜

zjdh

2016-6-29 18:03

查询名单.rar (17.66 KB, 下载次数: 32)

2016-6-29 18:03 上传

点击文件名下载附件

跳转到最佳答案楼层

zjdh

查询名单.rar (17.66 KB, 下载次数: 32)

2016-6-29 18:03 上传

点击文件名下载附件

scl5801

brr(1,i)=i这句是序号。