Excel多级下拉选择菜单的总结贴.doc
Excel多级下拉选择菜单的总结贴 第1例：EXCEL自动对应选择下拉菜单背景：某工厂的Excel表，首先选择车间，然后再选择不同工序，每一个工序对应不同的步骤。工序与步骤存放在【详细工序步骤】工作表中，表中的第一行为工序名，每一个工序名所在列中存储对应的步骤名：实现：第一步：由于选择车间与其它选择无关，车间名称也不会轻意改变，因此可以用复制上一行的有效性的方法来实现。同样的理由工序也这样处理，代码如下： 复制内容到剪贴板 代码:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row > 2 And Target.Column <3 Then Target.Offset(-1, 0).Copy Target.PasteSpecial (xlPasteValidation) End IfEnd Sub上述代码在Sheet1中实现了双击第1、2列，会自动复制上一行的有效性。是通过选择性粘贴实现的。下面的代码实现：当第2列改变时，第3列的有效性会相应改变； 复制内容到剪贴板 代码:Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim r As Range, c As Range Dim sStr As String If Target.Row > 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详见具体实例：EXCEL自动对应选择下拉菜单 本帖最后由 美猴王 于 2008-3-19 12:55 编辑 让你的Excel更精彩！ 2 帖子 720 精华 2 积分 683 阅读权限 150 性别 男 在线时间 792 小时 注册时间 2007-11-20 最后登录 2008-8-27 查看详细资料TOP 美猴王 美猴王超级版主· 发短消息 · 加为好友 · 当前离线 3# 大 中 小 发表于 2008-3-19 08:42 只看该作者 第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, sStr As String) With T.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sStr End WithEnd Sub与上例不同的是，选择菜单的格式不同。详见具体实例：Excel多级下拉菜单，数据自动填充
