[接龙...]部分程序代码注释，目录更新20051222

hhkg

好贴！从里面学到很多、很多！

Long_III

16、录制宏在图表里的操作。整个过程基本都是靠录制宏来完成的，原文件在http://club.excelhome.net/viewthread.php?tid=1156985楼 i8yMCYBr.rar (11.2 KB, 下载次数: 249)

2005-8-16 16:05 上传

点击文件名下载附件

[此贴子已经被作者于2005-8-16 16:06:07编辑过]

Long_III

17、根据单元格内容，插入图片到相应的单元格中。复制附件到D盘哦，附代码：

Private Sub CommandButton1_Click() Dim rng As Range Dim p Dim ps As Shape Const Spath$ = "D:/Pic/" '设置图片的位置 For Each ps In ActiveSheet.Shapes If Not Application.Intersect(ps.TopLeftCell, Range("d:d")) Is Nothing Then ps.Delete Next '删除指定区域的图片 Set rng = [c1] Do If Dir(Spath & rng.Value) <> "" Then '假设图片存在时 Set p = ActiveSheet.Pictures.Insert(Spath & rng.Value) '插入图片 With p .Top = rng.Offset(0, 1).Top .Left = rng.Offset(0, 1).Left .Height = rng.Offset(0, 1).Height .Width = rng.Offset(0, 1).Width '设置插入图片的位置，与单元格一致 End With End If Set rng = rng.Offset(1, 0) Loop Until rng.Value = "" '循环到最后一个单元格 End Sub 9lnQgvJA.rar (151.85 KB, 下载次数: 319)

2005-8-16 15:11 上传

点击文件名下载附件
[接龙...]部分程序代码注释，供一些入门选手学习！

Long_III

18、自动生成打印表！

比较简单的代码，在原处做了备注，附件里有详细的注释，这里只做一个链接http://club.excelhome.net/viewthread.php?tid=110454 7楼

随便链接一个简单代码，也是工作表转换的问题http://club.excelhome.net/viewthread.php?tid=116403 3楼

[此贴子已经被作者于2005-8-17 11:45:19编辑过]

wangwei

这对于我们新手来说真的不错，接龙吗本人还没这个能力，正处于学习阶段！

Long_III

19、提取批注里的内容，生成明细表，split函数的应用！例子是taller斑竹给别人的答案，原处http://club.excelhome.net/viewthread.php?tid=116645。代码

sF6HPdax.rar (54.45 KB, 下载次数: 335)

2005-8-18 12:54 上传

点击文件名下载附件
[接龙...]部分程序代码注释，供一些入门选手学习！

Private Sub CommandButton1_Click() Dim cel As Range '定义格式为单元格 Dim cmt, txt Dim i%, iR%

Application.ScreenUpdating = False '关闭屏幕更新 With Sheets("Result") '如果一个对象多次被引用，就需要才用with……end with格式了，可以加快代码速度 .Rows("2:65536").Delete '删除原先的数据 For Each cel In Columns("K:AO").SpecialCells(xlCellTypeComments) '定位K:AO列中所有的批注对应的单元格，在里面逐一循环 cmt = Split(cel.Comment.Text, Chr(10)) '把单元格的批注对应的文本按chr(10)分开，代码最下面示范1 For i = 1 To UBound(cmt) '从1开始循环，忽略了数组的第一个cmt(0)＝"Walter:" txt = Split(cmt(i), " ") '再次对这个数组里的元素进行分割成4行数，代码最下面示范2 iR = .[a65535].End(xlUp).Row + 1 '每次循环都重新计算最后一个非空行+1 .Cells(iR, 1) = txt(0) .Cells(iR, 2).Resize(1, 4).Value = Cells(cel.Row, 1).Resize(1, 4).Value .Cells(iR, 6) = txt(3) .Cells(iR, 8) = txt(2) '按实际要求给单元格赋值 Next Next .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal '全部单元格赋值之后按A1单元格排序，可用录制宏得到 .Range(.[G2], .[H65536].End(xlUp).Offset(0, -1)).FormulaR1C1 = "=RC[-3]*RC[-1]" '设置金额列的公式，等于单价[-3]*数量[-1] '此处可以体现处RC格式的优势，shuiyuan大师有详细的介绍可搜索到 .Activate '激活rusult表 End With Application.ScreenUpdating = True End Sub

'此处可参考split函数和chr函数的帮助 'Walter: 'IL-11177 1001 張三 10 'IL-11166 1003 王五 5 'IL-11170 1010 阿海 15

'1、用cmt ＝ Split(cel.Comment.Text, Chr(10))，会生成4行数，cmt(0) = 第一行，cmt(1) = 第二行，类似

'2、IL-11177 1001 張三 10用split(cmt(i)," ")，生成4行数，txt(0) = "L-11177",txt(1) = "1001",txt(2) = "張三",txt(3) = 10

790830

全部收到 研究中

紫蝶儿菲菲

真是好啊，谢谢了。终于能够明白好多的问题了。

17小菜

来个菜单设置:

Sub Menu_Face() '设置界面菜单 On Error Resume Next Dim Popup(2) Dim Button As CommandBarControl CommandBars("My").Delete Set Popup(0) = Application.CommandBars.Add(Name:="MY", Position:=msoBarTop, MenuBar:=True) 'MenuBar:=True为菜单 With Popup(0) .Protection = msoBarNoMovem '返回或设置指定命令栏的保护方式，以防止用户改动 .Visible = True End With Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(1).Caption = " 文件控制 " Call MyButton(Popup(1), False, " 1. 用户切换", 355, "Login", True) Call MyButton(Popup(1), False, " 2. 文件存盘", 3, "File_Save", True) Call MyButton(Popup(1), False, " 3. 密码修改", 548, "Pass_Modify", True) Call MyButton(Popup(1), False, " 4. 退出文件", 1019, "File_Close", True) Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(1).Caption = " 数据处理 " Call MyButton(Popup(1), False, " 1. 福彩数据", 162, "Data_3D", True) Call MyButton(Popup(1), False, " 2. 体彩数据", 162, "Data_P3", True) Call MyButton(Popup(1), True, " 3. 往期查看", 439, "Data_See", False) Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(1).Caption = " 图表查看 " Set Popup(2) = Popup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(2).Caption = " 1. 和值" Call MyButton(Popup(2), False, " 1.1 竖排", 17, "Data_B1", True) Call MyButton(Popup(2), False, " 1.2 横排", 17, "Data_B2", True) Set Popup(2) = Popup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(2).Caption = " 2. 合值" Call MyButton(Popup(2), False, " 2.1 合值", 17, "Data_B3", True) Call MyButton(Popup(2), False, " 2.2 合值跨度", 17, "Data_B4", True) Call MyButton(Popup(1), True, " 3. 跨度", 17, "Data_B5", True) Set Popup(2) = Popup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(2).Caption = " 4. 开奖号码" Call MyButton(Popup(2), False, " 4.1 大中小", 17, "Data_B7", True) Call MyButton(Popup(2), False, " 4.2 012路", 17, "Data_B8", True) Call MyButton(Popup(2), True, " 4.3 竖排", 17, "Data_BSG", True) Call MyButton(Popup(2), False, " 4.4 横排", 17, "Data_B6", True) Call MyButton(Popup(2), True, " 4.5 百位", 17, "Data_B12", True) Call MyButton(Popup(2), False, " 4.6 十位", 17, "Data_B13", True) Call MyButton(Popup(2), False, " 4.7 个位", 17, "Data_B14", True) Set Popup(2) = Popup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(2).Caption = " 5. 大小奇偶质合" Call MyButton(Popup(2), False, " 5.1 百位", 17, "Data_B9", True) Call MyButton(Popup(2), False, " 5.2 十位", 17, "Data_B10", True) Call MyButton(Popup(2), False, " 5.3 个位", 17, "Data_B11", True) Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup, Temporary:=True) Popup(1).Caption = " 文件信息 " Call MyButton(Popup(1), False, " 1. 注册信息", 607, "File_Register", True) Call MyButton(Popup(1), False, " 2. 关于作者", 487, "About", True) Call MyButton(Popup(1), True, " 3. 返回主页", 132, "Back_Face", True) Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup, Temporary:=True) With Popup(1) .Caption = " 玩法选择(&X) " .FaceId = 439 .OnAction = "Data_See" .Enabled = False End With End Sub

Sub MyButton(MyPopup, BeginGroup As Boolean, Caption As String, FaceId As Integer, OnAction As String, Enabled As Boolean) Set Button = MyPopup.Controls.Add(Type:=msoControlButton) Button.BeginGroup = BeginGroup '菜单隔断 Button.Caption = Caption '菜单名称 Button.FaceId = FaceId '菜单图标 Button.OnAction = OnAction '执行宏名 Button.Enabled = Enabled '菜单灰白否 End Sub

紫蝶儿菲菲

好是好啊，就是退出的时候，没有恢复excel的默认菜单啊。咋办啊。