excel常用宏集合.docx
《excel常用宏集合.docx》由会员分享，可在线阅读，更多相关《excel常用宏集合.docx（59页珍藏版）》请在冰豆网上搜索。
excel常用宏集合
65：
删除包含固定文本单元的行或列
Sub删除包含固定文本单元的行或列（）
Do
（what:
="哈哈"）.Activate
'删除行
''删除列
LoopUntil（what:
="哈哈"）IsNothing
EndSub
72：
在指定颜色区域选择单元时添加/取消"√"（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
DimmyrgAsRange
ForEachmyrgInTarget
If=37Thenmyrg=IIf（myrg<>"√","√",""）
Next
EndSub
73：
在指定区域选择单元时添加/取消"√"（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
DimRngAsRange
If<=15Then
IfNot（Target,Range（"D6:
D20"））IsNothingThen
ForEachRngInSelection
WithRng
If.Value=""Then
.Value="√"
Else
.Value=""
EndIf
EndWith
Next
EndIf
EndIf
EndSub
74：
双击指定单元，循环录入文本（工作表代码）
PrivateSubWorksheet_BeforeDoubleClick（ByValTAsRange,CancelAsBoolean）
If<>"$A$1"ThenExitSub
Cancel=True
T=IIf（T="好","中",IIf（T="中","差","好"））
EndSub
75：
双击指定单元，循环录入文本（工作表代码）
DimnumsAsByte
PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）
If="$A$1"Then
nums=numsMod3+1
Target=Mid（"上中下",nums,1）
（1,0）.Select
EndIf
EndSub
76：
单元区域引用（工作表代码）
PrivateSubWorksheet_Activate（）
（"A1:
B3"）.Value=（"A1:
B3"）.Value
EndSub
77：
在指定区域选择单元时数值加1（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
IfNot（[a1:
e10],Target）IsNothingThen
Target=Val（Target）+1
EndIf
EndSub
259个常用宏-excelhome（3）
2009-08-1514:
12:
58
78：
混合文本的编号
Sub混合文本的编号（）
Worksheets
（1）.Range（"B2"）.Value="北京"&（--（Mid（Worksheets
（1）.Range（"B2"）,3,100））+1）
EndSub
79：
指定区域单元双击数据累加（工作表代码）
PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）
IfNot（[A1:
Y100],Target）IsNothingThen
oldvalue=Val
inputvalue=InputBox（"请输入数量,按ENTER键确认!
","数值累加器"）
=oldvalue+inputvalue
EndIf
EndSub
80：
选择单元区域触发事件（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
If="$A$1:
$B$2"Then
MsgBox"你选择了$A$1:
$B$2单元"
EndIf
EndSub
81：
当修改指定单元内容时自动执行宏（工作表代码）
PrivateSubWorksheet_Change（ByValTargetAsRange）
IfNot（Target,[B3:
B4]）IsNothingThen
重排窗口
EndIf
EndSub
82：
被指定单元内容限制执行宏
Sub被指定单元限制执行宏（）
IfRange（"$A$1"）="关闭"ThenExitSub
窗口
EndSub
83：
双击单元隐藏该行（工作表代码）
PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）
Rows.Hidden=True
EndSub
84：
高亮显示行（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
=2
Rows（"1:
2"）.=40'保持1至2行的颜色推荐39,22,40,
Rows.=35'高亮推荐颜色35,20,24,34,37,40,15
EndSub
85：
高亮显示行和列（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
=xlNone
Rows.=34
Columns.=34
EndSub
86：
为指定工作表设置滚动范围（工作簿代码）
PrivateSubWorkbook_SheetSelectionChange（ByValShAsObject,ByValTargetAsRange）
="A1:
M30"
EndSub
87：
在指定单元记录打印和预览次数（工作簿代码）
PrivateSubWorkbook_BeforePrint（CancelAsBoolean）
Range（"A1"）=1+Range（"A1"）
EndSub
88：
自动数字金额转大写（工作表代码）
PrivateSubWorksheet_Change（ByValMAsRange）
OnErrorResumeNext
y=Int（Round（100*Abs（M））/100）
j=Round（100*Abs（M）+-y*100
f=（j/10-Int（j/10））*10
A=IIf（y<1,"",（y,"[DBNum2]"）&"元"）
b=IIf（j>,（Int（j/10）,"[DBNum2]"）&"角",IIf（y<1,"",IIf（f>1,"零",""）））
c=IIf（f<1,"整",（Round（f,0）,"[DBNum2]"）&"分"）
M=IIf（Abs（M）<,"",IIf（M<0,"负"&A&b&c,A&b&c））
EndSub
89：
将所有工作表的A1单元作为单击按钮（工作簿代码）
PrivateSubWorkbook_SheetSelectionChange（ByValShAsObject,ByValTargetAsRange）
If="$A$1"Then
Call宏名
EndIf
EndSub
90：
闹钟——到指定时间执行宏（工作簿代码）
PrivateSubWorkbook_Open（）
（"11:
45:
00"）,"提示1"'宏名字
（"12:
00:
00"）,"提示2"'宏名字
EndSub
91：
改变Excel界面标题的宏（工作簿代码）
PrivateSubWorkbook_Open（）
="春节快乐"
EndSub
92：
在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）
PrivateSubWorkbook_SheetSelectionChange（ByValShAsObject,ByValTargetAsRange）
Worksheets（"表2"）.Range（"A1"）=（0,0）
EndSub
93：
B列录入数据时在A列返回记录时间（工作表代码）
PublicSubWorksheet_Change（ByValTargetAsRange）
If=2Then
（,-1）=Now
EndIf
EndSub
94：
当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）
PublicSubWorksheet_Change（ByValTargetAsRange）
IfNot（Target,[A1:
A1000]）IsNothingThen
If=1Then
（,1）=Date
（,2）=Time
EndIf
EndIf
EndSub
PublicSubWorksheet_Change（ByValTargetAsRange）
IfNot（Target,[A1:
A1000]）IsNothingThen
If=1Then
（,1）=Format（Now（）,"yyyy-mm-dd"）
（,2）=Format（Now（）,"h:
mm:
ss"）
EndIf
EndIf
EndSub
95：
指定单元显示光标位置内容（工作表代码）
PrivateSubWorksheet_SelectionChange（ByValTAsRange）
Sheets
（1）.Range（"A1"）=Selection
EndSub
96：
每编辑一个单元保存文件
PrivateSubWorksheet_Change（ByValTargetAsRange）
EndSub
97：
指定允许编辑区域
Sub指定允许编辑区域（）
="B8:
G15"
EndSub
98：
解除允许编辑区域限制
Sub解除允许编辑区域限制（）
=""
EndSub
99：
删除指定行
Sub删除指定行（）
Workbooks（"临时表"）.Sheets（"表2"）.Range（"5:
5"）.Delete
EndSub
100：
删除A列为指定内容的行
Sub删除A列为指定内容的行（）
Dima,bAsInteger
a=Sheet1.[a65536].End（xlUp）.Row
Forb=aTo2Step-1
IfCells（b,1）.Value="删除"Then
Rows（b）.Delete
EndIf
Next
EndSub
101：
删除A列非数字单元行
Sub删除A列非数字单元行（）
i=[a65536].End（xlUp）.Row
Range（"A1:
A"&i）.SpecialCells（xlCellTypeConstants,2）.
EndSub
102：
有条件删除当前行
Sub有条件删除当前行（）
If[A1]=2Or[B1]="删除"Then
Shift:
=xlUp
EndIf
EndSub
103：
选择下一行
Sub选择下一行（）
（1,0）.Rows（"1:
1"）.
EndSub
104：
选择第5行开始所有数据行
Sub选择第5行开始所有数据行A（）
Dimi%
i=（"*",SearchOrder:
=xlByRows,LookIn:
=xlValues,SearchDirection:
=xlPrevious）.
Rows（"5:
"&i）.Select
EndSub
Sub选择第5行开始所有数据行B（）
Rows（"5:
"&（"*",,,,1,2）.Row）.Select
EndSub
105：
选择光标或选区所在行
Sub选择光标或选区所在行（）
Sub
106：
选择光标或选区所在列
Sub选择光标或选区所在列（）
Sub
107：
光标定位到名称指定位置
Sub定位（）
Range（Evaluate（"名称"））
EndSub
108：
选择名称定义的数据区
Sub选择名称定义的数据区（）
[数据区].Select'插入名称要使用INDIRECT函数
'Range（"数据区"）.Select或者
'（"数据区"）.Select或者
EndSub
109：
选择到指定列的最后行
Sub选择到指定列的最后行（）
Range（"C4:
G"&[G65536].End（xlUp）.Row）.Select
EndSub
110：
将Sheet1的A列的非空值写到Sheet2的A列
Sub将Sheet1的A列的非空值写到Sheet2的A列（）
（"A:
A"）.SpecialCells（2,23）.SpecialCells（12）.CopySheet2.[A1]
EndSub
111：
将名称1的数据写到名称2
SubMacro2（）
Range（"位置2"）=Range（"位置1"）.Value
EndSub
112：
单元反选
Sub单元反选（）
=False
=False
DimraddressAsString,taddressAsString
raddress=
taddress=
.Range（taddress）=0
.Range（raddress）="=0"
raddress=.Range（taddress）.SpecialCells（xlCellTypeConstants,1）.Address
.Delete
EndWith
（raddress）.Select
=True
EndSub
113：
调整选中对象中的文字
Sub调整选中对象中的文字（）
'文字居中：
自动调整大小
WithSelection
.HorizontalAlignment=xlCenter
.VerticalAlignment=xlCenter
.ReadingOrder=xlContext
.Orientation=xlHorizontal
.AutoSize=True
.AddIndent=False
EndWith
EndSub
114：
去除指定范围内的对象
Sub去除指定范围内的对象（）
DimpAsShape
SetMy=Worksheets（"工作表名"）
ForEachpIn
IfNot,Range（"范围"））IsNothingThen
Next
EndSub
115：
更新透视表数据项
SubDeleteMissingItems2002All（）
'防止数据透视表中显示无用的数据项
'在Excel2002或更高版本中
'假如无用的数据项已经存在,
'运行这个宏可以更新
DimptAsPivotTable
DimwsAsWorksheet
ForEachwsIn
ForEachptIn
=xlMissingItemsNone
Nextpt
Nextws
EndSub
116：
将所有工作表名称写到A列
Sub将所有表名称写到A列（）
k=1
ForEachShtInSheets
Cells（k+1,1）='指定写入的行和列
k=k+1
Next
EndSub
117：
为当前选定的多单元插入指定名称
Sub为当前选定的多单元插入指定名称（）
="临时"
Name:
="临时",RefersTo:
=Selection'或者换用这行代码也可以
EndSub
118：
删除所有名称
Sub删除所有名称（）
OnErrorResumeNext
DimlAsInteger
l=i=lTo1Step-1
（i）.Delete
Next
EndSub
119：
以指定区域为表目录补充新表
Sub以指定区域为表目录补充新表（）
DimdicAsObject,shAsWorksheet
Dimarr,item
arr=Range（"B1:
BB1"）
Setdic=CreateObject（""）
ForEachshIn
""
Next
ForEachitemInarr
Ifitem<>""AndNot（Trim（item））Then
With.Name=item
EndWith
EndIf
Next
Setdic=Nothing
EndSub
120：
按A列数据批量修改表名称
Sub按A列数据批量修改表名称（）
Dimi%
Fori=1To-1
Sheets（i）.Name=Cells（i+1,1）.Text
Next
EndSub
121：
按A列数据批量创建新表（控件按钮代码）
PrivateSubCommandButton1_Click（）
OnErrorResumeNext
Dimi%,j%
Fori=1To[a65536].End（xlUp）.Row
Forj=2To
IfCells（i,1）=Sheets（j）.NameThen
ExitFor
EndIf
Next
（after:
=Sheets）.Name=Cells（i,1）
Next
EndSub
122：
清除剪贴板
Sub清除剪贴板（）
=False
（"TaskPane"）.Visible=False
EndSub
123：
批量清除软回车
Sub批量清除软回车（）
'也可直接使用Alt+10或13替换
What:
=Chr（10）,Replacement:
="",LookAt:
=xlPart,SearchOrder:
=_
xlByRows,MatchCase:
=False,SearchFormat:
=False,ReplaceFormat:
=False
EndSub
124：
判断指定文件是否已经打开
Sub判断指定文件是否已经打开（）
DimxAsInteger
Forx=1To
IfWorkbooks（x）.Name="函数.xls"Then'文件名称
MsgBox"文件已打开"
ExitSub
EndIf
Next
MsgBox"文件未打开"
EndSub
125：
当前文件另存到指定目录
Sub当前激活文件另存到指定目录（）
Filename:
="E:
\信件\"&
EndSub
126：
另存指定文件名
Sub另存指定文件名（）
&"\别名.xls"
EndSub
127：
以本工作表名称另存文件到当前目录
Sub以本工作表名称另存文件到当前目录（）
Filename:
=&"\"&&".xls"
EndSub
128：
将本工作表单独另存文件到Excel当前默认目录
Sub将本工作表单独另存文件到Excel当前默认目录（）
Filename:
=&".xls"
EndSub
129：
以活动工作表名称另存文件到Excel当前默认目录
Sub以活动工作表名称另存文件到Excel当前默认目录（）
Filename:
=&".xls",FileFormat:
=_
xlNormal,Password:
="",WriteResPassword:
="",ReadOnlyRecommended:
=False_
CreateBackup:
=False
EndSub
130：
另存所有工作表为工作簿
Sub另存所有工作表为工作簿（）
DimshtAsWorksheet
=False
ipath=&"\"
ForEachshtInSheets
ipath&&".xls"'（工作表名称为文件名）
'ipath&&Trim（sht.[d15]）&".xls"'（文件名称&D15单元内容）
'ipath&Trim（sht.[d15]）&".xls"'（文件名称为D15单元内容）
Next
=True
EndSub
131：
以指定单元内容为新文件名另存文件
Sub以指定单元内容为新文件名另存文件（）
Filename:
=&"\"&Sheet1.[A1]
EndSub
132：
以当前日期为新文件名另存文件
Sub以当前日期为新文件名另存文件（）
&"\"&Format（Now（）,"yyyymmdd"）&".xls"
EndSub
Sub以当前日期为名称另存文件（）
Filename:
=Date&".xls"
EndSub
133：
以当前日期和时间为新文件名另存文件
Sub以当前日期和时间为新文件名另存文件（）
&"\"&Format（Now（）,"yyyy"&"年"&"mm"&"月"&"dd"&"日"&"h"&"时"&"mm"&"分"&"ss"&"秒"）&".xls"
EndSub
134：
另存本表为TXT文件
Sub另存本表为TXT文件（）
DimsAsString
DimFullNameAsString,rngAsRange
=False
FullName=&".txt"）'以当前表名为TXT文件名
'FullName=Replace,".xls",".txt"）'以当前文件名为TXT文件名
'FullName=Replace,".xls",&".txt"）'以文件名&表名为TXT文件名
升级会员 