'--*********************************************************

'--请将该代码，复制到《设置数据有效性的工作表》中

'--*********************************************************

'--动态设置<数据有效性和模糊查询>的功能,请手工调整下面参数

Private Const Sheet_Name_1 As String = "项目成本明细表"     '--1.1>--<设置数据有效性>的工作表的名称

Private Const Sheet_Name_2 As String = "初始数据"           '--1.2>--<基础档案>的工作表的名称

Private Const YouXiaoXing_Hang As Long = 2                  '--2.1>--设置数据有效性单元格<所在的行>---------要求:-------------大于等于2

Private Const YouXiaoXing_Lie As Long = 4                   '--2.2>--设置数据有效性单元格<所在的列>---------要求:------------大于等于2

Private Const ShuJuYuan_KaiShiHang As Long = 4              '--3.1>--<数据源>--<开始的行号>----------------要求:--------------大于等于2

Private Const ShuJuYuan_SuoZaiLie As Long = 2               '--3.2>--<数据源>--<所在列的列号>--------------要求:--------------大于等于1

Private Const FuZhuLie_KaiShiHang As Long = 4               '--4.1>--<辅助列>--<开始的行号>----------------要求:--------------大于等于2

Private Const FuZhuLie_SuoZaiLie As String = "Z"           '--4.2>--<辅助列>--<辅助列的列号>--------------要求:--------------用字母表示,比如 ,X,Y ,Z ,AA 等等

'---------------

Private YanSe_BeiJing_1                                     '--颜色1

Private YanSe_BeiJing_2                                     '--颜色2

'--*********************************************************

Private Sub Worksheet_Change(ByVal Target As Range)

     '--当工作表中,单元格变化的时候,执行的程序

     Dim Hang As Long

     Dim Lie As Long

     Hang = Target.Row

     Lie = Target.Column

     '--建议将该单元格的行和列号,定位于<设置了数据有效性>的单元格的上面,

     '--这样敲回车的时候,选择的单元格,刚好定位到<设置了数据有效性>的单元格上

     '--检测设置的参数是否正确

     If Sheet_Name_1 <> ThisWorkbook.ActiveSheet.Name Then

                 MsgBox "您设置<数据有效性单元格>所在的--<工作表名称>,不符合要求, " _

             & vbCrLf & "" _

             & vbCrLf & "您设置的参数 = < " & Sheet_Name_1 & " >" _

             & vbCrLf & "" _

             & vbCrLf & "但是,当前激活的<工作表名称>   = < " & ThisWorkbook.ActiveSheet.Name & " > " _

             & vbCrLf & "" _

             & vbCrLf & "    请进入编辑器,修改下面的参数:    " _

             & vbCrLf & "" _

             & vbCrLf & "    参数    = < " & ThisWorkbook.ActiveSheet.Name & " > ", vbOKOnly + vbCritical, "提醒"

             Exit Sub

      End If

      If YouXiaoXing_Hang < 2 Or _

         YouXiaoXing_Lie < 2 Then

                 MsgBox "您设置的<数据有效性>的--<单元格的位置>,不符合要求, " _

             & vbCrLf & "" _

             & vbCrLf & "    请进入编辑器,修改下面的参数:    " _

             & vbCrLf & "" _

             & vbCrLf & "    参数   必须大于等于   < 2 > " _

             & vbCrLf & "" _

             & vbCrLf & "        参数   必须大于等于   < 2 >   ", vbOKOnly + vbCritical, "提醒"

             Exit Sub

      End If

     '--设置数据有效性和模糊查询结合的功能

      If Hang = YouXiaoXing_Hang - 1 Then                                           '--发生变化的  <行号>

             If Lie = YouXiaoXing_Lie Then                                          '--发生变化的  <列号>

                   Call 根据设置的参数_标注颜色

                   Call 根据填写的字符串_计算_数据有效性辅助列的数据

                   Call 动态设置_数据有效性的范围

              End If

      End If

End Sub

'--*************************************************************

'--以下为自定义的过程

'--df杨青业

'--2018-12-12

Public Sub 根据设置的参数_标注颜色()

     YanSe_BeiJing_1 = RGB(255, 218, 185)                                                '--设置底色

     YanSe_BeiJing_2 = RGB(176, 224, 230)

     '---

     With Worksheets(Sheet_Name_1)                                                       '--<数据有效性>工作表

'          .Cells(YouXiaoXing_Hang - 1, YouXiaoXing_Lie).Interior.Color = YanSe_BeiJing_1

'          .Cells(YouXiaoXing_Hang, YouXiaoXing_Lie).Interior.Color = YanSe_BeiJing_2

     End With

     With Worksheets(Sheet_Name_2)                                                       '--<基础档案>工作表

'          .Cells(ShuJuYuan_KaiShiHang - 1, ShuJuYuan_SuoZaiLie).Interior.Color = YanSe_BeiJing_1

'          .Cells(FuZhuLie_KaiShiHang - 1, FuZhuLie_SuoZaiLie).Interior.Color = YanSe_BeiJing_2

     End With

     

End Sub

Public Sub 根据填写的字符串_计算_数据有效性辅助列的数据()

    '--

     Dim Hang_1 As Long

     Dim ZhHang_1 As Long

     Dim ZhHang_2 As Long

     Dim Name_XiangMu As String

     Dim Name_Serch As String

     Name_Serch = CStr(Worksheets(Sheet_Name_1).Cells(YouXiaoXing_Hang - 1, YouXiaoXing_Lie).Value)                   '--模糊查询内容的单元格

     If Name_Serch = "" Then

         'MsgBox "您没有在单元格输入内容,不能执行模糊查询", vbOKOnly + vbCritical, "错误提醒"

          Exit Sub

     End If

     With Worksheets(Sheet_Name_2)                                                       '--基础档案工作表的名称

            .Columns(FuZhuLie_SuoZaiLie).ClearContents                                   '--清除<辅助列>的内容

            .Cells(FuZhuLie_KaiShiHang - 1, FuZhuLie_SuoZaiLie).Value = "数据有效性的辅助列" '--填写<辅助列>的标题

             ZhHang_1 = .Cells(.Rows.Count, ShuJuYuan_SuoZaiLie).End(xlUp).Row           '--判断<数据源>的最后行

             For Hang_1 = ShuJuYuan_KaiShiHang To ZhHang_1                               '--对<数据源>的列做循环

                 ZhHang_2 = .Cells(.Rows.Count, FuZhuLie_SuoZaiLie).End(xlUp).Row        '--判断<辅助列>的最后行

                 Name_XiangMu = .Cells(Hang_1, ShuJuYuan_SuoZaiLie).Value                '--获取<数据源>所在列的<字符串>

                 If InStr(1, Name_XiangMu, Name_Serch) > 0 Then                          '--模糊查询<数据源中字符串>

                       .Cells(ZhHang_2 + 1, FuZhuLie_SuoZaiLie).Value = Name_XiangMu     '--将模糊查询的结果,写入到<辅助列>

                 End If

             Next

     End With

End Sub

Sub 动态设置_数据有效性的范围()

    Dim Arr

    On Error Resume Next

    With Worksheets(Sheet_Name_2)

         ZhHang_2 = .Cells(.Rows.Count, FuZhuLie_SuoZaiLie).End(xlUp).Row                           '--判断<辅助列>的最后行

'         Arr = .Range(.Cells(FuZhuLie_KaiShiHang, FuZhuLie_SuoZaiLie), .Cells(ZhHang_2, FuZhuLie_SuoZaiLie))

    

    

    End With

    '--

    With Worksheets(Sheet_Name_1).Cells(YouXiaoXing_Hang, YouXiaoXing_Lie).Validation               '--设置有效性的单元格

        .Delete

'        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

        xlBetween, Formula1:="=初始数据!$Z$4:$Z$" & ZhHang_2 & ""

'        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

        xlBetween, Formula1:="=Worksheets(Sheet_Name_2).range(Worksheets(Sheet_Name_2).cells(FuZhuLie_KaiShiHang,FuZhuLie_SuoZaiLie),Worksheets(Sheet_Name_2).cells(ZhHang_2,FuZhuLie_SuoZaiLie))"

'         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

        xlBetween, Formula1:="=" & Sheet_Name_2 & "!$Z$" & FuZhuLie_KaiShiHang & ":$Z$" & ZhHang_2 & ""

        

         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

        xlBetween, Formula1:="=" & Sheet_Name_2 & "!$" & FuZhuLie_SuoZaiLie & "$" & FuZhuLie_KaiShiHang & ":$" & FuZhuLie_SuoZaiLie & "$" & ZhHang_2 & ""

        

        

        .IgnoreBlank = True

        .InCellDropdown = True

        .InputTitle = ""

        .ErrorTitle = ""

        .InputMessage = ""

        .ErrorMessage = ""

        .IMEMode = xlIMEModeNoControl

        .ShowInput = True

        .ShowError = True

    End With

    Application.SendKeys "%{down}"                                                                   '--数据有效性的下拉框,自动展开

End Sub

Sub 动态设置_数据有效性的范围_该方法有时候查不到数据()

    Dim Arr

    On Error Resume Next

    With Worksheets(Sheet_Name_2)

         ZhHang_2 = .Cells(.Rows.Count, FuZhuLie_SuoZaiLie).End(xlUp).Row                           '--判断<辅助列>的最后行

         Arr = .Range(.Cells(FuZhuLie_KaiShiHang, FuZhuLie_SuoZaiLie), .Cells(ZhHang_2, FuZhuLie_SuoZaiLie))

    End With

    '--

    With Worksheets(Sheet_Name_1).Cells(YouXiaoXing_Hang, YouXiaoXing_Lie).Validation               '--设置有效性的单元格

        .Delete

        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

        xlBetween, Formula1:="=初始数据!$Z$4:$Z$" & ZhHang_2 & ""

        .IgnoreBlank = True

        .InCellDropdown = True

        .InputTitle = ""

        .ErrorTitle = ""

        .InputMessage = ""

        .ErrorMessage = ""

        .IMEMode = xlIMEModeNoControl

        .ShowInput = True

        .ShowError = True

    End With

    Application.SendKeys "%{down}"                                                                   '--数据有效性的下拉框,自动展开

End Sub