Excel常用宏大全.docx
《Excel常用宏大全.docx》由会员分享,可在线阅读,更多相关《Excel常用宏大全.docx(27页珍藏版)》请在冰豆网上搜索。
Excel常用宏大全
Excel常用宏大全
(一)
259个常用宏-excelhome-LangQueS
(1)
2008-04-0117:
21
打开全部隐藏工作表
Sub打开全部隐藏工作表()
DimiAsInteger
Fori=1ToSheets.Count
Sheets(i).Visible=True
Nexti
EndSub
循环宏
Sub循环()
AAA=Range("C2")
DimiAsLong
DimtimesAsLong
times=AAA
'times代表循环次数,执行前把times赋值即可(不可小于1,不可大于47)
Fori=1Totimes
Call过滤一行
IfRange("完成标志")="完成"ThenExitFor'如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出
'IfSheets("传送参数").Range("A"&i).Text="完成"ThenExitFor '如果某列出现"完成"内容则退出循环
Nexti
EndSub
录制宏时调用“停止录制”工具栏
Sub录制宏时调用停止录制工具栏()
Application.CommandBars("StopRecording").Visible=True
EndSub
高级筛选5列不重复数据至指定表
Sub高级筛选5列不重复数据至Sheet2()
Sheets("Sheet2").Range("A1:
E65536")=""'清除Sheet2的A:
D列
Range("A1:
E65536").AdvancedFilterAction:
=xlFilterCopy,CopyToRange:
=Sheet2.Range(_
"A1"),Unique:
=True
Sheet2.Columns("A:
E").SortKey1:
=Sheet2.Range("A2"),Order1:
=xlAscending,Header:
=xlGuess,_
OrderCustom:
=1,MatchCase:
=False,Orientation:
=xlTopToBottom,SortMethod_
:
=xlPinYin
EndSub
双击单元执行宏(工作表代码)
PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)
IfRange("$A$1")="关闭"ThenExitSub
SelectCaseTarget.Address
Case"$A$4"
Call宏1
Cancel=True
Case"$B$4"
Call宏2
Cancel=True
Case"$C$4"
Call宏3
Cancel=True
Case"$E$4"
Call宏4
Cancel=True
EndSelect
EndSub
双击指定区域单元执行宏(工作表代码)
PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)
IfRange("$A$1")="关闭"ThenExitSub
IfNotApplication.Intersect(Target,Range("A4:
A9","C4:
C9"))IsNothingThenCall打开隐藏表
EndSub
进入单元执行宏(工作表代码)
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
'以单元格进入代替按钮对象调用宏
IfRange("$A$1")="关闭"ThenExitSub
SelectCaseTarget.Address
Case"$A$5"'单元地址(Target.Address),或命名单元名字(Target.Name)
Call宏1
Case"$B$5"
Call宏2
Case"$C$5"
Call宏3
EndSelect
EndSub
进入指定区域单元执行宏(工作表代码)
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
IfRange("$A$1")="关闭"ThenExitSub
IfNotApplication.Intersect(Target,Range("A4:
A9","C4:
C9"))IsNothingThenCall打开隐藏表
EndSub
在多个宏中依次循环执行一个(控件按钮代码)
PrivateSubCommandButton1_Click()
StaticRunMacroAsInteger
SelectCaseRunMacro
Case0
宏1
RunMacro=1
Case1
宏2
RunMacro=2
Case2
宏3
RunMacro=0
EndSelect
EndSub
在两个宏中依次循环执行一个并相应修改按钮名称(控件按钮代码)
PrivateSubCommandButton1_Click()
WithCommandButton1
If.Caption="保护工作表"Then
Call保护工作表
.Caption="取消工作表保护"
ExitSub
EndIf
If.Caption="取消工作表保护"Then
Call取消工作表保护
.Caption="保护工作表"
ExitSub
EndIf
EndWith
EndSub
在三个宏中依次循环执行一个并相应修改按钮名称(控件按钮代码)
OptionExplicit
PrivateSubCommandButton1_Click()
WithCommandButton1
If.Caption="宏1"Then
Call宏1
.Caption="宏2"
ExitSub
EndIf
If.Caption="宏2"Then
Call宏2
.Caption="宏3"
ExitSub
EndIf
If.Caption="宏3"Then
Call宏3
.Caption="宏1"
ExitSub
EndIf
EndWith
EndSub
根据A1单元文本隐藏/显示按钮(控件按钮代码)
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
IfRange("A1")>2Then
CommandButton1.Visible=1
Else
CommandButton1.Visible=0
EndIf
EndSub
PrivateSubCommandButton1_Click()
重排窗口
EndSub
当前单元返回按钮名称(控件按钮代码)
PrivateSubCommandButton1_Click()
ActiveCell=CommandButton1.Caption
EndSub
当前单元内容返回到按钮名称(控件按钮代码)
PrivateSubCommandButton1_Click()
CommandButton1.Caption=ActiveCell
EndSub
奇偶页分别打印
Sub奇偶页分别打印()
Dimi%,Ps%
Ps=ExecuteExcel4Macro("GET.DOCUMENT(50)")'总页数
MsgBox"现在打印奇数页,按确定开始."
Fori=1ToPsStep2
ActiveSheet.PrintOutfrom:
=i,To:
=i
Nexti
MsgBox"现在打印偶数页,按确定开始."
Fori=2ToPsStep2
ActiveSheet.PrintOutfrom:
=i,To:
=i
Nexti
EndSub
自动打印多工作表第一页
Sub自动打印多工作表第一页()
DimshAsInteger
Dimx
Dimy
Dimsy
Dimsyz
x=InputBox("请输入起始工作表名字:
")
sy=InputBox("请输入结束工作表名字:
")
y=Sheets(x).Index
syz=Sheets(sy).Index
Forsh=yTosyz
Sheets(sh).Select
Sheets(sh).PrintOutfrom:
=1,To:
=1
Nextsh
EndSub
查找A列文本循环插入分页符
Sub循环插入分页符()
'Selection=Workbooks("临时表").Sheets("表2").Range("A1")调用指定地址内容
DimiAsLong
DimtimesAsLong
times="a:
a"),"分页")
'times代表循环次数,执行前把times赋值即可(不可小于1,不可大于47)
Fori=1Totimes
Call插入分页符
Nexti
EndSub
Sub插入分页符()
Cells.Find(What:
="分页",After:
=ActiveCell,LookIn:
=xlValues,LookAt:
=_
xlPart,SearchOrder:
=xlByRows,SearchDirection:
=xlNext,MatchCase:
=False)_
.Activate
Before:
=ActiveCell
EndSub
Sub取消原分页()
Cells.Select
ActiveSheet.ResetAllPageBreaks
EndSub
将A列最后数据行以上的所有B列图片大小调整为所在单元大小
Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小()
DimPicAsPicture,i&
i=[A65536].End(xlUp).Row
ForEachPicInSheet1.Pictures
IfNotApplication.Intersect(Pic.TopLeftCell,Range("B1:
B"&i))IsNothingThen
Pic.Top=
Pic.Left=
Pic.Height=
Pic.Width=
EndIf
Next
EndSub
返回光标所在行数
Sub返回光标所在行数()
x=ActiveCell.Row
Range("A1")=x
EndSub
在A1返回当前选中单元格数量
Sub在A1返回当前选中单元格数量()
[A1]=Selection.Count
EndSub
返回当前工作簿中工作表数量
Sub返回当前工作簿中工作表数量()
t=
MsgBoxt
EndSub
返回光标选择区域的行数和列数
Sub返回光标选择区域的行数和列数()
x=
y=
Range("A1")=x
Range("A2")=y
EndSub
工作表中包含数据的最大行数
Sub包含数据的最大行数()
n=Cells.Find("*",,,,1,2).Row
MsgBoxn
EndSub
返回A列数据的最大行数
Sub返回A列数据的最大行数()
n=Range("a65536").End(xlUp).Row
Range("B1")=n
EndSub
将所选区域文本插入新建文本框
Sub将所选区域文本插入新建文本框()
ForEachragInSelection
n=n&rag.Value&Chr(10)
Next
,ActiveCell.Left+ActiveCell.Width,ActiveCell.Top+ActiveCell.Height,250#,100).Select
="问题:
"&n
WithSelection.Characters(Start:
=1,Length:
=3).Font
.Name="黑体"
.FontStyle="常规"
.Size=12
EndWith
EndSub
批量插入地址批注
Sub批量插入地址批注()
OnErrorResumeNext
DimrAsRange
If>0Then
ForEachrInSelection
r.AddComment
=False
Text:
="本单元格:
"&r.Address&"of"&Selection.Address
Next
EndIf
EndSub
批量插入统一批注
Sub批量插入统一批注()
DimrAsRange,msgAsString
msg=InputBox("请输入欲批量插入的批注","提示","随便输点什么吧")
If>0Then
ForEachrInSelection
r.AddComment
=False
Text:
=msg
Next
EndIf
EndSub
以A1单元内容批量插入批注
Sub以A1单元内容批量插入批注()
DimrAsRange
If>0Then
ForEachrInSelection
r.AddComment
=False
Text:
=[a1].Text
Next
EndIf
EndSub
不连续区域插入当前文件名和表名及地址
Sub批量插入当前文件名和表名及地址()
ForEachmycellInSelection
mycell.FormulaR1C1="["+ActiveWorkbook.Name+"]"+ActiveSheet.Name+"!
"+mycell.Address
Next
EndSub
不连续区域录入当前单元地址
Sub区域录入当前单元地址()
ForEachmycellInSelection
mycell.FormulaR1C1=mycell.Address
Next
EndSub
连续区域录入当前单元地址
Sub连续区域录入当前单元地址()
Selection="=ADDRESS(ROW(),COLUMN(),4,1)"
Selection.Copy
Selection.PasteSpecialPaste:
=xlPasteValues,Operation:
=xlNone,SkipBlanks_
:
=False,Transpose:
=False
EndSub
返回当前单元地址
Sub返回当前单元地址()
d=ActiveCell.Address
[A1]=d
EndSub
不连续区域录入当前日期
Sub区域录入当前日期()
Selection.FormulaR1C1=Format(Now(),"yyyy-m-d")
EndSub
不连续区域录入当前数字日期
Sub区域录入当前数字日期()
Selection.FormulaR1C1=Format(Now(),"yyyymmdd")
EndSub
不连续区域录入当前日期和时间
Sub区域录入当前日期和时间()
Selection.FormulaR1C1=Format(Now(),"yyyy-m-dh:
mm:
ss")
EndSub
不连续区域录入对勾
Sub批量录入对勾()
Selection.FormulaR1C1="√"
EndSub
不连续区域录入当前文件名
Sub批量录入当前文件名()
Selection.FormulaR1C1=ThisWorkbook.Name
EndSub
不连续区域添加文本
Sub批量添加文本()
DimsAsRange
ForEachsInSelection
s=s&"文本内容"
Next
EndSub
不连续区域插入文本
Sub批量插入文本()
DimsAsRange
ForEachsInSelection
s="文本内容"&s
Next
EndSub
从指定位置向下同时录入多单元指定内容
Sub从指定位置向下同时录入多单元指定内容()
Dimarr
arr=Array("1","2","13","25","46","12","0","20")
[B2].Resize(8,1)=
EndSub
按aa工作表A列的内容排列工作表标签顺序
Sub按aa工作表A列的内容排列工作表标签顺序()
DimI%,str1$
I=1
Sheets("aa").Select
DoWhileCells(I,1).Value<>""
str1=Trim(Cells(I,1).Value)
Sheets(str1).Select
Sheets(str1).Moveafter:
=Sheets(I)
I=I+1
Sheets("aa").Select
Loop
EndSub
以A1单元文本作表名插入工作表
Sub以A1单元文本作表名插入工作表()
DimnmAsString
nm=[a1]
Sheets.Add
ActiveSheet.Name=nm
EndSub
Excel常用宏大全
(二)
删除全部未选定工作表
Sub删除全部未选定工作表()
DimshtAsWorksheet,nAsInteger,iFlagAsBoolean
DimShtName()AsString
n=
ReDimShtName(1Ton)
n=1
ForEachshtInActiveWindow.SelectedSheets
ShtName(n)=sht.Name
n=n+1
Next
Application.DisplayAlerts=False
ForEachshtInSheets
iFlag=False
Fori=1Ton-1
IfShtName(i)=sht.NameThen
iFlag=True
ExitFor
EndIf
Next
IfNotiFlagThensht.Delete
Next
Application.DisplayAlerts=True
EndSub
工作表标签排序
Sub工作表标签排序()
DimiAsLong,jAsLong,numsAsLong,msgAsLong
msg=MsgBox("工作表按升序排列请选'是[Y]'."&vbCrLf&vbCrLf&"工作表按降序排列请选'否[N]'",vbYesNoCancel,"工作表排序")
Ifmsg=vbCancelThenExitSub
nums=Sheets.Count
Ifmsg=vbYesThen'Sortascending
Fori=1Tonums
Forj=iTonums
IfUCase(Sheets(j).Name) Sheets(j).MoveBefore:
=Sheets(i)
EndIf
Nextj
Nexti
Else'Sortdescending
Fori=1Tonums
Forj=iTonums
IfUCase(Sheets(j).Name)>UCase(Sheets(i).Name)Then
Sheets(j).MoveBefore:
=Sheets(i)
EndIf
Nextj
Nexti
EndIf
EndSub
259个常用宏-excelhome-LangQueS
(2)
2008-04-0117:
22
定义指定工作表标签颜色
Sub定义指定工作表标签颜色()
Sheets("Sheet1").Tab.ColorIndex=46
EndSub
在目录表建立本