excel常用宏集合.docx

excel常用宏集合.docx

《excel常用宏集合.docx》由会员分享，可在线阅读，更多相关《excel常用宏集合.docx（69页珍藏版）》请在冰豆网上搜索。

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文件名