Excel多级下拉选择菜单的总结贴.doc

Excel多级下拉选择菜单的总结贴这里所说的下拉选择菜单是利用Excel的有效性功能中的顺序实现的：题目位置第1例Excel自动对应选择下拉菜单2楼第2例Excel多级下拉菜单，数据自动填充3楼第1例：EXCEL自动对应选择下拉菜单背景：某工厂的Excel表，首先选择车间，然后再选择不同工序，每一个工序对应不同的步骤。工序与步骤存放在【详细工序步骤】工作表中，表中的第一行为工序名，每一个工序名所在列中存储对应的步骤名：AB1面线护掌2驳位穿轻胶3面双针世轻胶4透气胶章贴手叉5织唛拉边6拉边拉护丈巾7拉丈巾剪护丈巾8车护掌全件实现：第一步：由于选择车间与其它选择无关，车间名称也不会轻意改变，因此可以用复制上一行的有效性的方法来实现。同样的理由工序也这样处理，代码如下： 复制内容到剪贴板 代码:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row 2 And Target.Column 1 And Target.Column = 2 And Target.Count = 1 Then If Target.Value Then Set ws = Worksheets(详细工序步骤) Set r = ws.Rows(1).Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchByte:=Fals) If Not r Is Nothing Then Set c = ws.Cells(2, r.Column) Do While c sStr = sStr & , & c.Value Set c = c.Offset(1, 0) Loop Set r = Nothing Set c = Nothing Call DynamicValidation(Target.Offset(0, 1), sStr) End If Set ws = Nothing End If End IfEnd SubPrivate Sub DynamicValidation(ByVal T As Range, sStr As String) With T.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sStr End WithEnd Sub第2例：Excel多级下拉菜单，数据自动填充背景：某工厂的Excel表，要求在B列可以自动生成产品系列的下拉菜单，然后C列的菜单内容随之变化，D列根据C列的选择自动调出对应工作表的计划量，同时在E列加一超级连接，点击后可以转到相应的工作表中。生产计划用料汇总表序号产品系列产品名称计划量(Kg)备注11.纯净系列21.纯净系列珍珠纯净美白洁面乳(滋润型)1sheet431.纯净系列纯净美白修护面膜1111sheet641.纯净系列珍珠纯净美白洁面乳(泡沫型)10000sheet553.极度系列极度保湿洁肤乳62.清爽防晒系列71.先在产品系列中选择系列(B2-B29)2.当选择系列后产品名称处显示为当前系列内所有的选择菜单(产品菜单在产品目录表里可以)3.输入本次生产的计划数量(如多少KG)4.能不能实现我点击一下转到就可以转到我所选择产品的配方中,8生产计划用料汇总表序号产品系列产品名称对应工作表11.纯净系列2纯净美白修护面膜sheet63珍珠纯净美白洁面乳(泡沫型)sheet54珍珠纯净美白洁面乳(滋润型)sheet45珍珠纯净美白精华液sheet46珍珠纯净美白柔肤水sheet472.清爽防晒系列8清爽防晒乳SPF-289清爽防晒乳 SPF-1310晒后修护精华113.极度系列12极度保湿洁肤乳13极度保湿乳14极度保湿霜(北方市场)实现：在计划单中：1、双击B列单元格，则会产生选项菜单；2、B列单元格选项菜单发生变化时，C列菜单也会随之变化；3、C列单元格选项菜单发生变化时，E列会出现相对应的工作表名；4、双击E列的工作表名会转到此表；5、D列计划量数值的变化可以自动填写对应计划表中。在目录工作表中设置相应的选择菜单。下面的代码实现了第1项和第4项功能 复制内容到剪贴板 代码:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim sStr As String, sFirstAddress As String, sTableName As String Dim ws As Worksheet Dim c As Range If Target.Count = 1 Then If Target.Row 2 And Target.Column = 2 Then Set ws = Worksheets(产品目录) Set c = ws.Range(B2:B65535).Find(What:=*, LookIn:=xlValues) If Not c Is Nothing Then sStr = sFirstAddress = c.Address Do sStr = sStr & , & c.Value Set c = ws.Range(B3:B65536).FindNext(c) Loop While Not c Is Nothing And c.Address sFirstAddress Call DynamicValidation(Target, sStr) End If Cancel = True End If If Target.Row 1 And Target.Column = 5 Then sTableName = Target.Value On Error Resume Next Worksheets(sTableName).Visible = xlSheetVisible Worksheets(sTableName).Activate If Err.Number 0 Then MsgBox 表 & sTableName & 不存在！, vbExclamation, 智能Excel End If On Error GoTo 0 End If End IfEnd Sub下面的代码实现了第2、3、5项功能Private Sub Worksheet_Change(ByVal Target As Range) Dim sStr As String Dim ws As Worksheet Dim c As Range If Target.Count = 1 Then If Target.Row 2 And Target.Column = 2 Then Set ws = Worksheets(产品目录) Set c = ws.Range(B2:B65535).Find(What:=Target.Value, LookIn:=xlValues) If Not c Is Nothing Then sStr = Set c = c.Offset(1, 1) Do While c.Value sStr = sStr & , & c.Value Set c = c.Offset(1, 0) Loop Call DynamicValidation(Target.Offset(0, 1), sStr) End If End If If Target.Row 2 And Target.Column = 3 Then Set ws = Worksheets(产品目录) Set c = ws.Range(C2:C65535).Find(What:=Target.Value, LookIn:=xlValues) If Not c Is Nothing Then Target.Offset(0, 2) = c.Offset(0, 1).Value End If End If If Target.Row 2 And Target.Column = 4 Then On Error Resume Next Worksheets(Target.Offset(0, 1).Value).Cells(8, g) = Target.Value On Error GoTo 0 End If End IfEnd SubPrivate Sub DynamicValidation(ByVal T As Range, sS