VBA 代码段汇集[不断的更新中]

民扬 · 发表于 2018-12-22 12:02

'各位网友，这个模块可是很有用哦！在新模块中添加以下代码：
Declare Function GetTickCount Lib "kernel32" () As Long
Public Function py(TT) As Variant  '自定义函数，目的：把一组汉字变为一组汉字拼音的第一个字母。
      py = ""
      For i = 1 To Len(TT)
      Temp = Asc(Mid$(TT, i, 1))
      If Temp > 255 Or Temp < 0 Then '是汉字吗？
         py = py & PinYin(Mid$(TT, i, 1)) '转化为拼音首字母，
      Else
         py = py & LCase(Mid$(TT, i, 1))  '转化英文字母
      End If
      Next i
End Function
Function PinYin(Hz As String)
Dim PinMa As String
Dim MyPinMa As Variant
Dim Temp As Integer, i As Integer, j As Integer
PinMa = "a,20319,ai,20317,an,20304,ang,20295,ao,20292,"
PinMa = PinMa & "ba,20283,bai,20265,ban,20257,bang,20242,bao,20230,bei,20051,ben,20036,beng,20032,bi,20026,bian,20002,biao,19990,bie,19986,bin,19982,bing,19976,bo,19805,bu,19784,"
PinMa = PinMa & "ca,19775,cai,19774,can,19763,cang,19756,cao,19751,ce,19746,ceng,19741,cha,19739,chai,19728,chan,19725,chang,19715,chao,19540,che,19531,chen,19525,cheng,19515,chi,19500,chong,19484,chou,19479,chu,19467,chuai,19289,chuan,19288,chuang,19281,chui,19275,chun,19270,chuo,19263,ci,19261,cong,19249,cou,19243,cu,19242,cuan,19238,cui,19235,cun,19227,cuo,19224,"
PinMa = PinMa & "da,19218,dai,19212,dan,19038,dang,19023,dao,19018,de,19006,deng,19003,di,18996,dian,18977,diao,18961,die,18952,ding,18783,diu,18774,dong,18773,dou,18763,du,18756,duan,18741,dui,18735,dun,18731,duo,18722,"
PinMa = PinMa & "e,18710,en,18697,er,18696,"
PinMa = PinMa & "fa,18526,fan,18518,fang,18501,fei,18490,fen,18478,feng,18463,fo,18448,fou,18447,fu,18446,"
PinMa = PinMa & "ga,18239,gai,18237,gan,18231,gang,18220,gao,18211,ge,18201,gei,18184,gen,18183,geng,18181,gong,18012,gou,17997,gu,17988,gua,17970,guai,17964,guan,17961,guang,17950,gui,17947,gun,17931,guo,17928,"
PinMa = PinMa & "ha,17922,hai,17759,han,17752,hang,17733,hao,17730,he,17721,hei,17703,hen,17701,heng,17697,hong,17692,hou,17683,hu,17676,hua,17496,huai,17487,huan,17482,huang,17468,hui,17454,hun,17433,huo,17427,"
PinMa = PinMa & "ji,17417,jia,17202,jian,17185,jiang,16983,jiao,16970,jie,16942,jin,16915,jing,16733,jiong,16708,jiu,16706,ju,16689,juan,16664,jue,16657,jun,16647,"
PinMa = PinMa & "ka,16474,kai,16470,kan,16465,kang,16459,kao,16452,ke,16448,ken,16433,keng,16429,kong,16427,kou,16423,ku,16419,kua,16412,kuai,16407,kuan,16403,kuang,16401,kui,16393,kun,16220,kuo,16216,"
PinMa = PinMa & "la,16212,lai,16205,lan,16202,lang,16187,lao,16180,le,16171,lei,16169,leng,16158,li,16155,lia,15959,lian,15958,liang,15944,liao,15933,lie,15920,lin,15915,ling,15903,liu,15889,long,15878,lou,15707,lu,15701,lv,15681,luan,15667,lue,15661,lun,15659,luo,15652,"
PinMa = PinMa & "ma,15640,mai,15631,man,15625,mang,15454,mao,15448,me,15436,mei,15435,men,15419,meng,15416,mi,15408,mian,15394,miao,15385,mie,15377,min,15375,ming,15369,miu,15363,mo,15362,mou,15183,mu,15180,"
PinMa = PinMa & "na,15165,nai,15158,nan,15153,nang,15150,nao,15149,ne,15144,nei,15143,nen,15141,neng,15140,ni,15139,nian,15128,niang,15121,niao,15119,nie,15117,nin,15110,ning,15109,niu,14941,nong,14937,nu,14933,nv,14930,nuan,14929,nue,14928,nuo,14926,"
PinMa = PinMa & "o,14922,ou,14921,"
PinMa = PinMa & "pa,14914,pai,14908,pan,14902,pang,14894,pao,14889,pei,14882,pen,14873,peng,14871,pi,14857,pian,14678,piao,14674,pie,14670,pin,14668,ping,14663,po,14654,pu,14645,"
PinMa = PinMa & "qi,14630,qia,14594,qian,14429,qiang,14407,qiao,14399,qie,14384,qin,14379,qing,14368,qiong,14355,qiu,14353,qu,14345,quan,14170,que,14159,qun,14151,"
PinMa = PinMa & "ran,14149,rang,14145,rao,14140,re,14137,ren,14135,reng,14125,ri,14123,rong,14122,rou,14112,ru,14109,ruan,14099,rui,14097,run,14094,ruo,14092,"
PinMa = PinMa & "sa,14090,sai,14087,san,14083,sang,13917,sao,13914,se,13910,sen,13907,seng,13906,sha,13905,shai,13896,shan,13894,shang,13878,shao,13870,she,13859,shen,13847,sheng,13831,shi,13658,shou,13611,shu,13601,shua,13406,shuai,13404,shuan,13400,shuang,13398,shui,13395,shun,13391,shuo,13387,si,13383,song,13367,sou,13359,su,13356,suan,13343,sui,13340,sun,13329,suo,13326,"
PinMa = PinMa & "ta,13318,tai,13147,tan,13138,tang,13120,tao,13107,te,13096,teng,13095,ti,13091,tian,13076,tiao,13068,tie,13063,ting,13060,tong,12888,tou,12875,tu,12871,tuan,12860,tui,12858,tun,12852,tuo,12849,"
PinMa = PinMa & "wa,12838,wai,12831,wan,12829,wang,12812,wei,12802,wen,12607,weng,12597,wo,12594,wu,12585,"
PinMa = PinMa & "xi,12556,xia,12359,xian,12346,xiang,12320,xiao,12300,xie,12120,xin,12099,xing,12089,xiong,12074,xiu,12067,xu,12058,xuan,12039,xue,11867,xun,11861,"
PinMa = PinMa & "ya,11847,yan,11831,yang,11798,yao,11781,ye,11604,yi,11589,yin,11536,ying,11358,yo,11340,yong,11339,you,11324,yu,11303,yuan,11097,yue,11077,yun,11067,"
PinMa = PinMa & "za,11055,zai,11052,zan,11045,zang,11041,zao,11038,ze,11024,zei,11020,zen,11019,zeng,11018,zha,11014,zhai,10838,zhan,10832,zhang,10815,zhao,10800,zhe,10790,zhen,10780,zheng,10764,zhi,10587,zhong,10544,zhou,10533,zhu,10519,zhua,10331,zhuai,10329,zhuan,10328,zhuang,10322,zhui,10315,zhun,10309,zhuo,10307,zi,10296,zong,10281,zou,10274,zu,10270,zuan,10262,zui,10260,zun,10256,zuo,10254"
MyPinMa = Split(PinMa, ",")

For i = 1 To Len(Hz)
Temp = Asc(Mid(Hz, i, 1))
If Temp < 0 Then
   Temp = Abs(Temp)
   For j = 791 To 1 Step -2
      If Temp <= Val(MyPinMa(j)) Then
            'PinYin = PinYin & MyPinMa(j - 1) & " "
            PinYin = PinYin & (Mid$(MyPinMa(j - 1), 1, 1))
            Exit For
      End If
   Next
End If
Next
PinYin = Trim(PinYin)
End Function

民扬 · 发表于 2018-12-23 13:38

vba 连接mysql
Dim cn As ADODB.Connection '定义数据链接对象，保存连接数据库信息；请先添加ADO引用
Dim rs As ADODB.Recordset '定义记录集对象，保存数据表
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
'设服务器地址、所连数据，及登录用户密码
ser = "localhost"
Db = "你的数据库名字"
user = "root"
pwd = "root"
strconnt = "DRIVER={MySQL ODBC 5.3 Unicode Driver};SERVER=" & ser & ";Database=" & Db & ";Uid=" & user & ";Pwd=" & pwd
cn.ConnectionString = strconnt
cn.Open
以上为连接代码，网上都有的。折腾我三小时的是mysql odbc数据源驱动
最开始下载mysql odbc驱动,我的系统是win7 64位，下载的是64位驱动
提示您的系统“找不到myodbc5S.dll”
试了好久，最后发现要安装vc++ 2013运行库
又在微软下载vc++ 2013运行库
再次安装，ok
但vba运行代码，提示报错"未发现数据源名称并且未指定默认驱动程序"
查看-管理工具-数据源，MySQL ODBC 5.3 Unicode Driver驱动已经有了。
百思不得其解，最后在网上找到原因，虽然我的系统是64位，但office是32位的，要32位的mysql odbc驱动
下载32位的mysql odbc驱动，安装又提示“找不到myodbc5S.dll”，恍然大悟，vc++运行库是64位的，又从新下载32位库，最后运行代码成功。
以下是需要用到的下载的官方网址
mysql odbc驱动forwin：
https://dev.mysql.com/downloads/connector/odbc/
vc++ 2013运行库：
http://download.microsoft.com/do ... e3/vcredist_x86.exe

blackttea1 · 发表于 2018-12-23 16:10

赞一个，标记一下。

民扬 · 发表于 2018-12-23 19:03

单元格输入公式和使用函数

在公式中一般会出现对单元格地址的引用，引用的方式有绝对引用（A1方式）和相对引用（R1C1）方式，同样的，在用VBA输入公式时，也会有两种方式。
1.1 输入A1格式的公式

向单元格输入公式，实际上就是输入公式的字符串。这时采用Range的value属性或Formula属性均可。

.Range("E11").Formula ="=sum(E2:E10)"

1.2 输入R1C1公式

使用R1C1格式向单元格输入公式，实际上是录制宏的方式。是一种地址相对引用的方式，这里的相对引用的基准地址就是公式所在的地址，以此地址为基准，偏移行R和列C得到相对引用位置。有些人可能喜欢这种方式，不过这种方式不像A1方式那样直观和容易理解。

(如果不是很熟悉VBA的语法格式，可以采取录制宏的方式去得到代码；如果觉得R1C1格式不习惯，可以在在Excel中设置公式的引用方式为A1（在Excel选项的公式项中设置），输入公式后再复制到VBA代码中。)

.Range("G11").FormulaR1C1 = "=SUM(R[-9]C:R[-1]C)";

[]中的数据代表单元格相对于当前单元格的行列偏移。

1.3 输入数组公式

向单元格或单元格区域输入数组公式，需要使用FormulaArray属性。

Range("E1:E11")FormulaArray ="=C2:C10*D2:D10"

2 使用函数

2.1 VBA引用Excel内置函数

.Range("A16") ="=find(""."",A13,1)"

.Range("A18") =Application.WorksheetFunction.Find(".", fname, 1)

(在VBE的代码窗口中输入Application.WorksheetFunction.可以得到引用Excel内置函数的提示；)

2.2 VBA引用VBA内置函数

.Range("A14") = InStr(ActiveWorkbook.Name,".")

(在VBE的代码窗口中输入VBA.，可以得到内置函数的提示；)

2.3 自定义函数

函数过程的标志以Function开头，定义好以后，可以像调用Excel已定义的函数一样通过等于号去使用它。

如：

Function 及格率(cell As Range)

及格率=WorksheetFunction.CountIf(cell,">=60") / WorksheetFunction.CountIf(cell, ">0")

及格率=Format(及格率, "0.00%")

End Function

自定义函数可以必须有返回值，所以有函数体中必须至少被赋值一次，也因此在Function后跟数据类型定义；

Function过程通常三种方式调用：

（1）在工作表中通过公式调用：像内部函数一样在工作表中使用，也可以与其它函数嵌套。使用方法如下：

公式→插入函数→类别：用户定义→选择函数；

（2）在VBA代码中被其它过程调用。

（3）递归：Function过程和Sub一样可以实现递归。如果不是刻意地、有计划地进入递归状态，可以会造成资源耗尽或者溢出堆栈空间。例如下例函数的调用：

在VBA语言中，也有预定义一些函数，与Excel预定义的相同功能的函数有细微区别）。

运行以下VBA：

Sub formulaTest()

With ActiveWorkbook.Sheets("使用公式和函数")

For i = 2 To 10

.Range("E" & i).Value = "=sum(A"& i & ":D" & i & "2)"

.Range("G11").FormulaR1C1 ="=SUM(R[-9]C:R[-1]C)"

.Range("G2:G10").FormulaArray ="=E2:E10*F2:F10"

.Range("A13") = ActiveWorkbook.Name

Dim fname As String

fname = Range("A13").Value

.Range("A14") = InStr(ActiveWorkbook.Name,".")

.Range("A15") = InStr([A13], ".")

.Range("A16") ="=find(""."",A13,1)"

.Range("A17") = InStr(fname, ".")

.Range("A18") =Application.WorksheetFunction.Find(".", fname, 1)

.Range("A19") =Application.WorksheetFunction.Find(".", [A13], 1)

'[A13]相当于range("A13")

End With

'Instr([start,]string1,string2[,compare])

End Sub

舒云天 · 发表于 2018-12-24 20:09

赞一个，标记一下

民扬 · 发表于 2018-12-28 08:59

常用内置对话框参数

1、“高级筛选”对话框

application.Dialogs(xlDialogFilterAdvanced).Showarg1:=xlFilterInPlace,arg2:=activesheet.usedrange,arg3:=[criterior]

参数1：在原区域显示筛选结果。参数2：列表区域。参数3：条件区域

application.Dialogs(xlDialogFilterAdvanced).Showarg1:=xlFilterCopy,arg2:=activesheet.usedrange,arg3:=[criterior],arg4:=sheets(sheets.Count).[a1],arg5:=true

参数1：将筛选出的数据复制到新位置参数4：目标区域参数5：选择不重复记录

2、“打开”对话框

Application.Dialogs(xlDialogOpen).Showarg1:="*t*.txt" 搜索当前文本夹中文件名中含有t关键字的文本文件

Application.Dialogs(xlDialogOpen).Showarg1:="d:\*.txt" 可以改变当前目录，在D盘搜索文本文件

Application.Dialogs(xlDialogOpen).Showarg1:="d:\*.txt;*.doc;*.xls" 可以搜索D盘的文本文件、WORD文本和EXCEL文件，具体可以自己定义，注意中间用分号间隔。此语句非常实用，仍然记得自己在初次发现时的狂喜心情，隆重推荐！！！

Application.Dialogs(xlDialogOpen).Showarg1:="d:\*1*;*2*" 搜索D盘含有1或2关键字的文件，也很实用

application.Dialogs(1).Showarg1:=CreateObject("Wscript.Shell").SpecialFolders("Desktop")& "\*.lnk"

搜索桌面的快捷方式

application.Dialogs(1).Showarg1:=CreateObject("Wscript.Shell").SpecialFolders("favorites")& "\*.*"

搜索收藏夹文件夹

application.Dialogs(1).Showarg1:=CreateObject("Wscript.Shell").SpecialFolders("startmenu")& "\*.*"

搜索开始菜单所有文件

application.Dialogs(1).Showarg1:=CreateObject("Wscript.Shell").SpecialFolders("mydocuments")& "\*.xls;*.doc"

搜索“我的文档”中的EXCEL及WORD文件

application.Dialogs(1).Show arg1:="d:\??学生*.xls"

搜索D盘中关键字为学生的EXCEL文件，这里两种通配符都可以使用

此外常用的特殊文件夹还有Startup、Fonts、Programs、Recent、SendTo、StartMenu、Templates

3、“标准字体”对话框

这个对话框更改的不是单元格格式，而是横纵座标的字体字号等格式，太神奇了！！！，而且这种更改只对当前工作薄有效，即使关闭EXCEL和关机，设置仍然保留。

参数说明：

name_text	arg1	字体
size_num	arg2	字号
bold	arg3	粗体
italic	arg4	斜体
underline	arg5	下划线
strike	arg6	删除线
color	arg7	字体颜色

Application.Dialogs(xlDialogStandardFont).Showarg1:="华文彩云",arg2:=20,arg3:=true

以上修改字体、字号和粗体，如果设置成各种西方字体，将使工作表画面呈现千变万化，充满情趣的效果，如果用Wingdings等三种字体，简直就成画板了！，当然，在游戏之余，还是要用庄重醒目的字体比较好。

4、“对齐方式”对话框

application.Dialogs(xlDialogAlignment).Showarg1:=3,arg2:=1 水平居中\自动换行

application.Dialogs(xlDialogAlignment).Showarg1:=2 左对齐

application.Dialogs(xlDialogAlignment).Showarg6:=1 缩小字体填充

application.Dialogs(xlDialogAlignment).Showarg8:=1 合并单元格

根据帮助说明，“对齐方式”对话框共有五个参数，分别为horiz_align, wrap, vert_align, orientation,add_indent，但实际说明并不完整，或者是一个“bug”,“缩小字体填充”和“合并单元格”参数说明中均没有，实际其分别位于参数6和参数8。这些都是不信邪大胆试的结果，大家在实践中要引以为鉴。

5、“页面设置”对话框

Application.Dialogs(7).Showarg9:=true,arg10:=true,arg11:=2方向横向，水平垂直居中

Application.Dialogs(7).Showarg3:=0,arg4:=0,arg5:=0,arg6:=0,arg18:=0,arg19:=0 页边距的六个数值参数均设置为0

Application.Dialogs(7).Show arg12:=9 纸型为A4

Application.Dialogs(7).Show arg13:=80 缩放比例为80%

Application.Dialogs(7).Show arg2:="共" & (ActiveSheet.HPageBreaks.Count +1) * (ActiveSheet.VPageBreaks.Count + 1) & "页" 页脚设置为“共*页”

Application.Dialogs(7).Show arg1:="第1页"这个是设置页眉，没有什么实际用途，原因是数字是死的，不会变动。无法模拟出自定义页眉中的类似WORD域的效果。

注意：页眉页脚打印标题行打印标题等参数不能进行默认设置，参数中也没有此项，不知道为什么。

6、“打印”对话框

Application.Dialogs(xlDialogPrint).Showarg4:=5 打印4份

application.Dialogs(8).Show arg2:=1,arg3:=2 打印1－2页

application.Dialogs(8).Show arg12:=1 打印选定区域。Arg12其他选项：2活动工作表 3整个工作薄

7、 “特殊选定”对话框（xlDialogSelectSpecial）

application.Dialogs(132).Show arg1:=3,arg2:=1定位公式－数值

application.Dialogs(132).Show arg1:=2,arg2:=3定位常量－公式文本

application.Dialogs(132).Showarg1:=2,arg2:=23 定位常量－全部

application.Dialogs(132).Show arg1:=4 定位空值

application.Dialogs(132).Show arg1:=5 定位当前区域

application.Dialogs(132).Show arg1:=6 定位当前数组

application.Dialogs(132).Show arg1:=7 定位行内容差异单元格

application.Dialogs(132).Show arg1:=8 定位列内容差异单元格

application.Dialogs(132).Show arg1:=9 定位引用单元格

application.Dialogs(132).Show arg1:=10 定位从属单元格

application.Dialogs(132).Showarg1:=10,arg3:=2 定位所有级别从属单元格

application.Dialogs(132).Show arg1:=11 定位最后一个单元格

application.Dialogs(132).Show arg1:=12 定位可见单元格

application.Dialogs(132).Show arg1:=13 定位对象

application.Dialogs(132).Show arg1:=14 定位条件格式

application.Dialogs(132).Show arg1:=15 定位全部数据有效性，在帮助“Range.SpecialCells 方法”中，定位有效性的类型值为-4174，用在定位对话框参数中就会出错。arg1:=15这种结果全是一点点摸索出来的，诸如此类的情况很多。大家用到其它对话框时往往要自己反复尝试，不要轻易放弃和否定。

application.Dialogs(132).Showarg1:=15,arg3:=2 定位相同数据有效性

8、“分列”对话框

application.Dialogs(xlDialogTextToColumns).Showarg2:=2 分列-文件类型为固定宽度

application.Dialogs(xlDialogTextToColumns).Showarg2:=1,arg5:=0,arg6:=1,arg7:=1,arg8:=1

分列-分隔符号为分号\逗号\空格

application.Dialogs(xlDialogTextToColumns).Showarg2:=2,arg11:=Array(0, 2)

分列-列数据类型为文本

application.Dialogs(xlDialogTextToColumns).Showarg2:=2,arg11:=Array(0, 5)

分列-列数据类型为YMD格式时间

application.Dialogs(xlDialogTextToColumns).Showarg2:=2,arg11:=Array(0, 3)

分列-列数据类型为MDY格式时间

9、“对齐方式”对话框

application.Dialogs(xlDialogAlignment).Showarg1:=3,arg2:=1 水平居中\自动换行

application.Dialogs(xlDialogAlignment).Showarg1:=2 左对齐

application.Dialogs(xlDialogAlignment).Showarg6:=1 缩小字体填充

application.Dialogs(xlDialogAlignment).Showarg8:=1 合并单元格

10、选择性粘贴对话框

application.Dialogs(53).Show arg1:=7 边框除外

application.Dialogs(53).Show arg1:=8 粘贴复制的列宽

application.Dialogs(53).Show arg1:=11 公式和数字格式

application.Dialogs(53).Show arg1:=6 粘贴有效性

application.Dialogs(53).Showarg1:=2,arg4:=true 粘贴公式/转置

arg1参数的其他选项值：3数值 4格式5批注 12粘贴值和数字格式

注意以上语句运行前，要有单元格处于被复制状态，否则运行出错。也可以用以下宏增强通用性，防止出错。

Public Sub abc1()

If Application.CutCopyMode = xlCopy Then

Application.Dialogs(53).Show arg1:=2, arg4:=True

End If

End Sub

民扬 · 发表于 2018-12-28 09:00

常用内置对话框参数
11、“查找公式”对话框
application.Dialogs(64).Show arg3:=1 1为全部匹配,2为部分匹配
application.Dialogs(64).Show arg2:=2 查找范围:1公式2值 3批注
application.Dialogs(64).Show arg6:=true 区分大小写
application.Dialogs(64).Show arg4:=1 按行搜索,值2为按列搜索

12、“替换公式”对话框
application.Dialogs(130).Showarg1:="*abc",arg2:="abc",arg3:=2 将"*abc"替换为”abc”,以部分匹配方式替换

13、“另存为”对话框
application.Dialogs(xlDialogSaveAs).Showarg1:=CreateObject("Wscript.Shell").SpecialFolders("desktop")& "\" & [a1] & ".xls"
保存文件到桌面，默认文件名为A1单元格值。
还可以更智能一些，如果A1为空，则以A列第一个值为默认文件名
Public Sub abc()
Dim folder, name
folder =CreateObject("Wscript.Shell").SpecialFolders("desktop")& "\"
If [a1] <> "" Then name =[a1] Else name = [a:a].Find("*")
Application.Dialogs(xlDialogSaveAs).Showarg1:=folder & name & ".xls"
End Sub

14、“创建分类汇总”对话框
application.Dialogs(xlDialogSubtotalCreate).Showarg2:=2 分类汇总函数为计数，其他参数：平均值为3，最大值为4，最小值为5，数值计数为7标准偏差为9
application.Dialogs(xlDialogSubtotalCreate).Showarg4:=false 替换当前分类汇总为否
application.Dialogs(xlDialogSubtotalCreate).Showarg5:=true 每组数据分页为是
application.Dialogs(xlDialogSubtotalCreate).Showarg6:=false 汇总结果显示在下方选项为否，arg6:=true则是结果显示在上方
application.Dialogs(xlDialogSubtotalCreate).Showarg2:=2,arg3:=1 对第一列进行计数
application.Dialogs(xlDialogSubtotalCreate).Showarg3:=array(2,3) 对第二三列进行求和
由于分类汇总对话框不能准确确定要进行计算的列，通过代码可以弥补这一不足。以下的程序即可以实现以上功能。假定数据表第一列为字段名，第二列以上为数据记录，通过判断数据为数值型确定要计算的列数组。分类汇总对话框则根据数据自动标识要求和的列
Public Sub abc()
Dim ar(), i, m
For i = 2 ToRange("a1").CurrentRegion.Columns.Count
IfIsNumeric(Cells(2, i)) Then
      m = m + 1
   ReDim Preserve ar(1 To m)
   ar(m) = i
EndIf
Next
Application.Dialogs(xlDialogSubtotalCreate).Showarg3:=ar
End Sub

15、“添加列表选项”对话框
application.Dialogs(xlDialogOptionsListsAdd).Show
EXCEL各版本进入自定义序列的路径都比较繁琐，用以上语句可以直接进入，相当于快捷方式了。

16、“计算”对话框
application.Dialogs(xlDialogCalculation).Showarg6:=true  以显示精度为准（这个比较有用，对一个小数，设置以显示精度为准，则减少小数位后就不可恢复了。相当于编辑小数值，而不是格式调整）
application.Dialogs(32).Show arg1:=3 设置计算模式为“手动重算”，参数值1为“自动重算”
application.Dialogs(32).Showarg1:=3,arg8:=false 保存前自动重算选项为否，这样可以加快文件保存速度。注意arg8和arg1必须同时设置才有效
这个对话框参数不少，但以前面三种应用最为常用。

17、“单元格保护”对话框
application.Dialogs(xlDialogCellProtection).Showarg1:=true,arg2:=true 设置单元格保护，锁定和隐藏两个选项均为是

18、“清除”对话框
application.Dialogs(xlDialogClear).Showarg1:=2 将清除格式设为默认选项，因为这一选项是最常用的
application.Dialogs(xlDialogClear).Showarg1:=iif(not selection(1).Comment is nothing,4,2)
加入一种更“人性化”的判断，如果第一个选定单元格中含有批注，则清除默认选项为“批注”，对有类似要求的用户这是一个较好的参考，但也很可能画蛇添足，多此一举，自己灵活把握吧
Application.Dialogs(xlDialogClear).Showarg1:=5将清除超链接设为默认选项。对此还可以用一组宏语句实现更智能化的应用，如果单元格存在超链接，则将清除超链接设为默认选项，否则将清除格式设为默认选项。代码如下：
Sub abc()
On Error Resume Next
Debug.PrintSelection(1).Hyperlinks(1).Address
If Err.Number > 0 Then
Application.Dialogs(xlDialogClear).Show arg1:=2
Else
Application.Dialogs(xlDialogClear).Show arg1:=5
End If
End Sub

19、合并计算
application.Dialogs(xlDialogConsolidate).Showarg1:=Array("Sheet1!R1C1:R4C2","Sheet2!R1C1:R5C2") 设定合并计算的所有引用位置，arg1的参数值是一个数组，包含各个参与合并的区域。如果自动准确添加所有引用位置，则需要用宏来实现。例如：
PublicSub abc()
Dimar(), i, m
For i= 1 To ActiveSheet.Index - 1
m = m+ 1
ReDim Preserve ar(1 To m)
ar(m) = Sheets(i).Name & "!"& Sheets(i).Range("a1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
Next
[a1].Select
Application.Dialogs(xlDialogConsolidate).Showarg1:=ar
EndSub
application.Dialogs(xlDialogConsolidate).Showarg2:=3 设置合并计算的函数为计数，其它参数值：1平均值，2数值计数，4最大值，5最小值，6乘积，9求和
application.Dialogs(xlDialogConsolidate).Showarg3:=true,arg4:=true 标签位置设定为首行为最左列
application.Dialogs(xlDialogConsolidate).Showarg5:=true 选定“创建指向源数据的链接”选项

20、“显示”对话框
application.Dialogs(xlDialogDisplay).Showarg1:=true 显示公式（而不是显示计算结果）
application.Dialogs(xlDialogDisplay).Showarg2:=false 不显示网格线
application.Dialogs(xlDialogDisplay).Showarg3:=false 不显示行号列标
application.Dialogs(xlDialogDisplay).Showarg4:=false 不显示零值
application.Dialogs(xlDialogDisplay).Showarg7:=false 不显示分级显示符号
application.Dialogs(xlDialogDisplay).Showarg8:=true 显示自动分页符
application.Dialogs(xlDialogDisplay).Showarg9:=3 参数值1为全部显示，2为仅显示位置

民扬 · 发表于 2018-12-28 09:02

常用内置对话框参数
Application.Dialogs(1).Show是调用打开对话框
Application.Dialogs(5或145).Show是调用另存为对话框，
Application.Dialogs(6).Show是删除文档
Application.Dialogs(7).Show是页面设置
Application.Dialogs(8).Show是打印对话框
Application.Dialogs(9).Show是选择打印机对话框
Application.Dialogs(12).Show是重排窗口设置对话框
Application.Dialogs(17).Show宏对话框
Application.Dialogs(23).Show设置打印标题
Application.Dialogs(26).Show字体设置对话框
Application.Dialogs(27).Show显示选项
Application.Dialogs(28).Show保护工作表
Application.Dialogs(32).Show重算选项
Application.Dialogs(39或192).Show排序
Application.Dialogs(40).Show序列选项
Application.Dialogs(41).Show模拟运算表
Application.Dialogs(42或111).Show单元格格式，选择单元格内容的格式
Application.Dialogs(43).Show选择单元格字体的排列格式，横排或竖排等
Application.Dialogs(44或134或190).Show字体选择
Application.Dialogs(45).Show边框格式设置
Application.Dialogs(46).Show对单元格的保护或隐藏选项
Application.Dialogs(47).Show列宽设置选项
Application.Dialogs(52).Show清除对话框
Application.Dialogs(53).Show选择性粘贴对话框
Application.Dialogs(54).Show删除对话框
Application.Dialogs(55).Show插入对话框
Application.Dialogs(61或110).Show定义名称对话框
Application.Dialogs(62).Show指定名称
Application.Dialogs(63或132).Show定位
Application.Dialogs(64).Show查找
Application.Dialogs(84).Show设置单元格颜色和图案
Application.Dialogs(91).Show分列
Application.Dialogs(94).Show取消或隐藏工作表选择对话框
Application.Dialogs(95).Show工作区视图等选项
Application.Dialogs(103).Show选择要激活哪个工作表对话框
Application.Dialogs(108).Show复制图片选项
Application.Dialogs(119).Show新建对话框
Application.Dialogs(127).Show设置行高
Application.Dialogs(130).Show替换对话框
Application.Dialogs(137).Show拆分当前窗口
Application.Dialogs(161).Show设置图表颜色
Application.Dialogs(170或171).Show移动当前窗口
Application.Dialogs(191).Show合并计算对话框
Application.Dialogs(198).Show单变量求解
Application.Dialogs(199).Show选定成组工作表
Application.Dialogs(200).Show填充成组工作表

lsc900707 · 发表于 2018-12-28 09:34

民扬发表于 2018-12-16 21:21

学过英语的人不用去记这些单词吧。

民扬 · 发表于 2018-12-30 15:52

VBA控件常规使用--ListBox 控件（一）

ListBox 控件的目的是为了向用户显示要选择的项目列表。您可以存储为 Excel 工作表上 ListBox 控件项目列表。使用 RowSource 属性来填充工作表, 上 ListBox 控件与范围的单元格。 ListBox 控件在使用 MultiSelect 属性, 时可设置为接受多重选择。

如何从 ListBox 控件获取当前选定项

使用 Value 属性的ListBox 控件可返回当前选定项。要返回单项选择 ListBox 控件, 中当前选定项请按照下列步骤操作：

1. 启动 Excel, 并打开新空白工作簿。

2. 在单元格 A 1: A 5Sheet, 键入了您要用于填充 ListBox 控件值。

3. 在工具菜单, 指向宏 , 然后单击 VisualBasic 编辑器。

4. 在插入菜单上, 单击要在工作簿中插入 UserForm UserForm 。

5. 将 ListBox 控件添加到 UserForm。

6. 双击 ListBox 控件以显示代码窗口对 ListBox 控件。

7. 在代码窗口, 为 ListBox 1 Click 事件键入下列代码：

Private Sub ListBox1_Click()

MsgBoxListBox1.Value

EndSub

8. 在运行菜单上, 单击运行子过程 / 用户窗体。

当单击列表, 中的项目与当前选定项目将出现一个消息框。

如何获取多选择 ListBox 控件中选定项

确定多选择 ListBox 控件, 中所选项目必须循环列表, 中所有项目并再查询 Selected 属性。要返回多选择, ListBox 控件中当前选定项请按照下列步骤操作：

1. 启动 Excel, 并打开新空白工作簿。

2. 在单元格 A 1: A 5Sheet, 键入了您要用于填充 ListBox 控件值。

3. 在工具菜单, 指向宏 , 然后单击 VisualBasic 编辑器。

4. 在插入菜单上, 单击要在工作簿中插入 UserForm UserForm 。

5. 将 ListBox 控件添加到 UserForm。

6. 在视图菜单上, 单击属性以查看属性窗口。

7. 键入值，对于下列ListBox 控件属性表示：

Property Value

----------- -----------------------

MultiSelect 1 - frmMultiSelectMulti

RowSource Sheet1!A1:A8

8. 将 CommandButton 控件添加到 UserForm。

9. 双击以显示代码窗口对于UserForm CommandButton 控件。

10. 在代码窗口, 为 CommandButton 1 Click 事件键入下列代码：

Sub CommandButton1_Click ()

'Loop through the items in the ListBox.

Forx = 0 to ListBox1.ListCount - 1

'If the item is selected...

IfListBox1.Selected(x) = True Then

'display the Selected item.

MsgBoxListBox1.List(x)

EndIf

Nextx

EndSub

11. 在运行菜单上, 单击运行子过程 / 用户窗体。

12. 列表中选择一个或多个项目。

13. 单击CommandButton 1 。

单击 CommandButton 1 , 后，在 ListBox 控件中选择每个项目显示在一个单独的消息框。 UserForm 在消息框中, 出现所有选定项后自动关闭。

		自动登录	找回密码
密码			免费注册

[分享] VBA 代码段汇集[不断的更新中]