excel宏文件集.docx
《excel宏文件集.docx》由会员分享，可在线阅读，更多相关《excel宏文件集.docx（88页珍藏版）》请在冰豆网上搜索。
excel宏文件集
打开全部隐藏工作表
Sub打开全部隐藏工作表（）
DimiAsInteger
Fori=1ToSheets.Count
Sheets（i）.Visible=True
Nexti
EndSub
循环宏
Sub循环（）
AAA=Range（"C2"）
DimiAsLong
DimtimesAsLong
times=AAA
'times代表循环次数，执行前把times赋值即可（不可小于1，不可大于2147483647）
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=Application.WorksheetFunction.CountIf（Sheet1.Range（"a:
a"）,"分页"）
'times代表循环次数，执行前把times赋值即可（不可小于1，不可大于2147483647）
Fori=1Totimes
Call插入分页符
Nexti
EndSub
Sub插入分页符（）
Cells.Find（What:
="分页",After:
=ActiveCell,LookIn:
=xlValues,LookAt:
=_
xlPart,SearchOrder:
=xlByRows,SearchDirection:
=xlNext,MatchCase:
=False）_
.Activate
ActiveWindow.SelectedSheets.HPageBreaks.AddBefore:
=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.TopLeftCell.Top
Pic.Left=Pic.TopLeftCell.Left
Pic.Height=Pic.TopLeftCell.Height
Pic.Width=Pic.TopLeftCell.Width
EndIf
Next
EndSub
返回光标所在行数
Sub返回光标所在行数（）
x=ActiveCell.Row
Range（"A1"）=x
EndSub
在A1返回当前选中单元格数量
Sub在A1返回当前选中单元格数量（）
[A1]=Selection.Count
EndSub
返回当前工作簿中工作表数量
Sub返回当前工作簿中工作表数量（）
t=Application.Sheets.Count
MsgBoxt
EndSub
返回光标选择区域的行数和列数
Sub返回光标选择区域的行数和列数（）
x=Selection.Rows.Count
y=Selection.Columns.Count
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
ActiveSheet.Shapes.AddTextbox（msoTextOrientationHorizontal,ActiveCell.Left+ActiveCell.Width,ActiveCell.Top+ActiveCell.Height,250#,100）.Select
Selection.Characters.Text="问题：
"&n
WithSelection.Characters（Start:
=1,Length:
=3）.Font
.Name="黑体"
.FontStyle="常规"
.Size=12
EndWith
EndSub
批量插入地址批注
Sub批量插入地址批注（）
OnErrorResumeNext
DimrAsRange
IfSelection.Cells.Count>0Then
ForEachrInSelection
r.Comment.Delete
r.AddComment
r.Comment.Visible=False
r.Comment.TextText:
="本单元格：
"&r.Address&"of"&Selection.Address
Next
EndIf
EndSub
批量插入统一批注
Sub批量插入统一批注（）
DimrAsRange,msgAsString
msg=InputBox（"请输入欲批量插入的批注","提示","随便输点什么吧"）
IfSelection.Cells.Count>0Then
ForEachrInSelection
r.AddComment
r.Comment.Visible=False
r.Comment.TextText:
=msg
Next
EndIf
EndSub
以A1单元内容批量插入批注
Sub以A1单元内容批量插入批注（）
DimrAsRange
IfSelection.Cells.Count>0Then
ForEachrInSelection
r.AddComment
r.Comment.Visible=False
r.Comment.TextText:
=[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）=Application.WorksheetFunction.Transpose（arr）
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
删除全部未选定工作表
Sub删除全部未选定工作表（）
DimshtAsWorksheet,nAsInteger,iFlagAsBoolean
DimShtName（）AsString
n=ActiveWindow.SelectedSheets.Count
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
定义指定工作表标签颜色
Sub定义指定工作表标签颜色（）
Sheets（"Sheet1"）.Tab.ColorIndex=46
EndSub
在目录表建立本工作簿中各表链接目录
Sub在目录表建立本工作簿中各表链接目录（）
Dims%,RngAsRange
OnErrorResumeNext
Sheets（"目录"）.Activate
IfErr=0Then
Sheets（"目录"）.UsedRange.Delete
Else
Sheets.Add
ActiveSheet.Name="目录"
EndIf
Fori=1ToSheets.Count
IfSheets（i）.Name<>"目录"Then
s=s+1
S
升级会员 