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

excel多级下拉选择菜单的总结贴第1例：excel自动对应选择下拉菜单背景：某工厂的excel表，首先选择车间，然后再选择不同工序，每一个工序对应不同的步骤。工序与步骤存放在【详细工序步骤】工作表中，表中的第一行为工序名，每一个工序名所在列中存储对应的步骤名：实现：第一步：由于选择车间与其它选择无关，车间名称也不会轻意改变，因此可以用复制上一行的有效性的方法来实现。同样的理由工序也这样处理，代码如下： 复制内容到剪贴板 代码: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详见具体实例：excel自动对应选择下拉菜单 本帖最后由 美猴王 于 2008-3-19 12:55 编辑 让你的excel更精彩！ uid 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 rang