Excel常见宏解析.docx
- 文档编号:6460084
- 上传时间:2023-01-06
- 格式:DOCX
- 页数:74
- 大小:39.05KB
Excel常见宏解析.docx
《Excel常见宏解析.docx》由会员分享,可在线阅读,更多相关《Excel常见宏解析.docx(74页珍藏版)》请在冰豆网上搜索。
Excel常见宏解析
清除剪贴板
Sub清除剪贴板()
Application.CutCopyMode=False
Application.CommandBars("TaskPane").Visible=False
EndSub
批量清除软回车
Sub批量清除软回车()
'也可直接使用Alt+10或13替换
Cells.ReplaceWhat:
=Chr(10),Replacement:
="",LookAt:
=xlPart,SearchOrder:
=_
xlByRows,MatchCase:
=False,SearchFormat:
=False,ReplaceFormat:
=False
EndSub
判断指定文件是否已经打开
Sub判断指定文件是否已经打开()
DimxAsInteger
Forx=1ToWorkbooks.Count
IfWorkbooks(x).Name="函数.xls"Then'文件名称
MsgBox"文件已打开"
ExitSub
EndIf
Next
MsgBox"文件未打开"
EndSub
当前文件另存到指定目录
Sub当前激活文件另存到指定目录()
ActiveWorkbook.SaveAsFilename:
="E:
\信件\"&ActiveWorkbook.Name
EndSub
另存指定文件名
Sub另存指定文件名()
ActiveWorkbook.SaveAsThisWorkbook.Path&"\别名.xls"
EndSub
以本工作表名称另存文件到当前目录
Sub以本工作表名称另存文件到当前目录()
ActiveWorkbook.SaveAsFilename:
=ThisWorkbook.Path&"\"&ActiveSheet.Name&".xls"
EndSub
将本工作表单独另存文件到Excel当前默认目录
Sub将本工作表单独另存文件到Excel当前默认目录()
ActiveSheet.Copy
ActiveWorkbook.SaveAsFilename:
=ActiveSheet.Name&".xls"
EndSub
以活动工作表名称另存文件到Excel当前默认目录
Sub以活动工作表名称另存文件到Excel当前默认目录()
ActiveWorkbook.SaveAsFilename:
=ActiveSheet.Name&".xls",FileFormat:
=_
xlNormal,Password:
="",WriteResPassword:
="",ReadOnlyRecommended:
=False_
CreateBackup:
=False
EndSub
另存所有工作表为工作簿
Sub另存所有工作表为工作簿()
DimshtAsWorksheet
Application.ScreenUpdating=False
ipath=ThisWorkbook.Path&"\"
ForEachshtInSheets
sht.Copy
ActiveWorkbook.SaveAsipath&sht.Name&".xls"'(工作表名称为文件名)
'ActiveWorkbook.SaveAsipath&sht.Name&Trim(sht.[d15])&".xls"'(文件名称&D15单元内容)
'ActiveWorkbook.SaveAsipath&Trim(sht.[d15])&".xls"'(文件名称为D15单元内容)
ActiveWorkbook.Close
Next
Application.ScreenUpdating=True
EndSub
以指定单元内容为新文件名另存文件
Sub以指定单元内容为新文件名另存文件()
ThisWorkbook.SaveAsFilename:
=ThisWorkbook.Path&"\"&Sheet1.[A1]
EndSub
以当前日期为新文件名另存文件
Sub以当前日期为新文件名另存文件()
ThisWorkbook.SaveAsThisWorkbook.Path&"\"&Format(Now(),"yyyymmdd")&".xls"
EndSub
Sub以当前日期为名称另存文件()
ActiveWorkbook.SaveAsFilename:
=Date&".xls"
EndSub
以当前日期和时间为新文件名另存文件
Sub以当前日期和时间为新文件名另存文件()
ThisWorkbook.SaveAsThisWorkbook.Path&"\"&Format(Now(),"yyyy"&"年"&"mm"&"月"&"dd"&"日"&"h"&"时"&"mm"&"分"&"ss"&"秒")&".xls"
EndSub
另存本表为TXT文件
Sub另存本表为TXT文件()
DimsAsString
DimFullNameAsString,rngAsRange
Application.ScreenUpdating=False
FullName=(ActiveSheet.Name&".txt")'以当前表名为TXT文件名
'FullName=Replace(ThisWorkbook.FullName,".xls",".txt")'以当前文件名为TXT文件名
'FullName=Replace(ThisWorkbook.FullName,".xls",ActiveSheet.Name&".txt")'以文件名&表名为TXT文件名
OpenFullNameForOutputAs#1'以读写方式打开文件,每次写内容都会覆盖原先的内容
'参考帮助,fullname为文件全名
ForEachrngInRange("a1").CurrentRegion
s=s&IIf(s="","","|")&rng.Value
Ifrng.Column=Range("a1").CurrentRegion.Columns.CountThen
Print#1,s&"|"'把数据写到文本文件里
s=""
EndIf
Next
Close#1'关闭文件
Application.ScreenUpdating=True
MsgBox"数据已导入文本"
EndSub
引用指定位置单元内容为部分文件名另存文件
Sub引用指定位置单元内容为部分文件名另存文件()
ActiveWorkbook.SaveAsFilename:
="E:
\信件\"&"解答"&Range("sheet1!
a1")&"郎雀.xls"
EndSub
将A列数据排序到D列
Sub将A列数据排序到D列()
[d:
d]=[a:
a].Value
[d:
d].SortKey1:
=Range("D1"),Order1:
=xlAscending,Header:
=xlYes
EndSub
将指定范围的数据排列到D列
Sub将指定范围的数据排列到D列()
Dimarr1,arr2,i%,x
arr1=Range("A1:
C3")
ReDimarr2(1ToUBound(arr1,1)*UBound(arr1,2),1To1)
ForEachxInApplication.Transpose(arr1)
i=i+1
arr2(i,1)=x
Nextx
Range("D1").Resize(i,1)=arr2
EndSub
光标移动
Sub光标移动()
ActiveCell.Offset(1,2).Select'向下移动1行,向右移动2列
EndSub
光标所在行上移一行
Sub光标所在行上移一行()
Dimi%
i=Split(ActiveCell.Address,"$")
(2)
Ifi>1Then
Rows(i).Cut
Rows(i-1).InsertShift:
=xlDown
EndIf
EndSub
加数据有效限制
Sub加数据有效限制()
WithSelection.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,Operator:
=_
xlBetween,Formula1:
="bigsun010@"
.IgnoreBlank=False
.InCellDropdown=False
.InputTitle=""
.ErrorTitle=""
.InputMessage=""
.ErrorMessage="要奋斗就会有牺牲,死人的事是经常发生的。
"
.IMEMode=xlIMEModeNoControl
.ShowInput=True
.ShowError=True
EndWith
EndSub
取消数据有效限制
Sub取消数据有效限制()
WithSelection.Validation
.Delete
.AddType:
=xlValidateInputOnly,AlertStyle:
=xlValidAlertStop,Operator_
:
=xlBetween
.IgnoreBlank=False
.InCellDropdown=False
.InputTitle=""
.ErrorTitle=""
.InputMessage=""
.ErrorMessage=""
.IMEMode=xlIMEModeNoControl
.ShowInput=True
.ShowError=True
EndWith
EndSub
重排窗口
Sub重排窗口()
Application.CommandBars("Web").Visible=False
Application.CommandBars("我的工具").Visible=False
Windows.ArrangeArrangeStyle:
=xlCascade
EndSub
按当前单元文本选择打开指定文件单元
Sub选择打开文件单元()
Dima
a=ActiveCell.Value
Range(a).Worksheet.Activate
Range(a).Select
EndSub
回车光标向右
Sub录入光标向右()
Application.MoveAfterReturnDirection=xlToRight
EndSub
回车光标向下
Sub录入光标向下()
Application.MoveAfterReturnDirection=xlDown
EndSub
保护工作表时取消选定锁定单元
Sub取消选定锁定单元()
ActiveSheet.EnableSelection=xlUnlockedCells'用于2000版
EndSub
保存并退出Excel
Sub保存并退出Excel()
Application.SendKeys("{ENTER}{ENTER}%fx")
ActiveWorkbook.Save
EndSub
隐藏/显示指定列空值行
Sub隐藏显示E列空值行()
Range("E1:
E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden=Not(Range("E1:
E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)
EndSub
深度隐藏指定工作表
Sub深度隐藏指定工作表()
Sheets("用户名密码").Visible=xlVeryHidden
EndSub
隐藏指定工作表
Sub隐藏指定工作表()
Sheets("用户名密码").Visible=false
EndSub
隐藏当前工作表
Sub隐藏当前工作表()
ActiveWindow.SelectedSheets.Visible=false
EndSub
返回当前工作表名称
Sub返回当前工作表名称()
wsName=ActiveSheet.Name
MsgBox"当前工作表为:
"&wsName
EndSub
获取上一次所进入工作簿的工作表名称
Sub获取上一次所进入工作簿的工作表名称()
MsgBoxWorkbooks
(2).ActiveSheet.Name
EndSub
按光标选定颜色隐藏本列其他颜色行
Sub按颜色筛选()'思路就是:
其它背景色之行全部隐藏
DimUseRow,AC,i'首先选择一个有颜色之单元格,然后动行宏,其它颜色所在行隐藏
UseRow=Cells.SpecialCells(xlCellTypeLastCell).Row'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格
IfActiveCell.Row>UseRowThen
MsgBox"请在要筛选的区域选择一个有颜色之单元格!
",vbExclamation,"错误"
Else
AC=ActiveCell.Column
Cells.EntireRow.Hidden=False'显示所有行
Fori=2ToUseRow
IfCells(i,AC).Interior.ColorIndex<>ActiveCell.Interior.ColorIndexThen
Cells(i,AC).EntireRow.Hidden=True'如果2至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行
EndIf
Next
EndIf
EndSub
打开工作簿自动隐藏录入表以外的其他表
PrivateSubWorkbook_Open()
Dimi
Fori=1ToSheets.Count
IfSheets(i).Name<>"录入"Then
Sheets(i).Visible=False
EndIf
Next
EndSub
除最左边工作表外深度隐藏所有表
Sub除最左边工作表外深度隐藏所有表()
Fori=2ToThisWorkbook.Sheets.Count
Sheets(i).Visible=xlSheetVeryHidden
Next
EndSub
关闭文件时自动隐藏指定工作表(ThisWorkbook)
PrivateSubWorkbook_BeforeClose(CancelAsBoolean)
ActiveWorkbook.Unprotect
Sheets("Sheet2").Visible=False
Sheets("Sheet3").Visible=False
ActiveWorkbook.ProtectStructure:
=True,Windows:
=False
EndSub
打开文件时提示指定工作表是保护状态(ThisWorkbook)
PrivateSubWorkbook_Open()
IfWorksheets("Sheet1").ProtectContents=TrueThen
MsgBox"Sheet1保护了."
EndIf
EndSub
插入10行
Sub插入10行()
Rows(ActiveCell.Row&":
"&ActiveCell.Row+9).Select
Selection.InsertShift:
=xlDown
EndSub
全选固定范围内小于0的单元
Sub全选固定范围内小于0的单元()
DimrngAsRange
Dimyvhf
ForEachrngInRange("d6:
i18")
Ifrng<0Then
yvhf=yvhf&rng.Address&","
EndIf
Next
Range(Left(yvhf,Len(yvhf)-1)).Select
EndSub
全选选定范围内小于0的单元
Sub全选选定范围内小于0的单元()
DimrngAsRange
Dimyvhf
ForEachrngInSelection
Ifrng<0Then
yvhf=yvhf&rng.Address&","
EndIf
Next
Range(Left(yvhf,Len(yvhf)-1)).Select
EndSub
固定区域单元分类变色
Sub单元分类变色()
DimrngAsRange
ForEachrngInRange("d6:
i18")
Ifrng<0Then
rng.Interior.ColorIndex=4'小于0的单元变绿底色
EndIf
Next
ForEachrngInRange("d6:
i18")
Ifrng>0Then
rng.Interior.ColorIndex=3'文本、假空和大于0的单元变红底色
EndIf
Next
ForEachrngInRange("d6:
i18")
Ifrng=0Then
rng.Interior.ColorIndex=2'空值和等于0的单元变白底色
EndIf
Next
EndSub
A列半角内容变红
SubA列半角内容变红()
DimrgAsRange,iAsLong
Application.ScreenUpdating=False
ForEachrgInCells.SpecialCells(xlCellTypeConstants,3)
Fori=1ToLen(rg)
IfAsc(Mid(rg,i,1))>0Thenrg.Characters(i).Font.ColorIndex=3
Next
Next
Application.ScreenUpdating=True
EndSub
单元格录入数据时运行宏的代码
PrivateSubWorksheet_Change(ByValTargetAsRange)
重排窗口
EndSub
焦点到A列时运行宏的代码
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
IfTarget.Column=1Then
宏名
EndIf
EndSub
根据B列最后数据快速合并A列单元格的控件代码
PrivateSubCommandButton1_Click()
Fori=1To[b65536].End(xlUp).Row
Forj=i+1To[b65536].End(xlUp).Row
IfRange("a"&j)=""Then
Range("a"&i&":
a"&j).Merge
Else
ExitFor
EndIf
Nextj
Nexti
EndSub
在F1单元显示光标位置批注内容的代码
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
a=Selection.Address
b=Range(a).NoteText
Cells(1,6)=b
EndSub
显示光标所在单元的批注的代码
DimrAsRange
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
OnErrorResumeNext
r.Comment.Visible=False
Setr=Target
r.Comment.Visible=True
EndSub
使单元内容保持不变的工作表代码
PrivateSubWorksheet_Change(ByValTargetAsRange)
[B2]="不可更改的数据"
EndSub
有条件执行宏
Sub高级筛选()
If[J1]=2Or[K1]="筛选"Then
Columns("D:
E").Select
Selection.Clear
Range("D1").Select
Columns("A:
B").AdvancedFilterAction:
=xlFilterCopy,CriteriaRange:
=Range(_
"G1:
G2"),CopyToRange:
=Range("D1"),Unique:
=False
EndIf
EndSub
有条件执行不同的宏
Sub有条件执行不同的宏()
If[b1].Value="A"Then
Application.Run"宏1"
ElseIf[b1].Value="B"Then
Application.Run"宏2"
EndIf
EndSub
提示确定或取消执行宏
Sub提示确定或取消执行宏()
IfvbOK=MsgBox("确定要复制吗?
",vbOKCancel)Then
Range("A4:
A14").CopyRange("b4:
b14")
Msgbox"复制结束"
EndIf
EndSub
提示开始和结束
Sub提示结束()
Msgbox"运行开始"
过程……
Msgbox"运行结束"
EndSub
拷贝指定表不相邻多列数据到新位置
Sub拷贝指定表不相邻多列数据到新位置()
Sheets("sheet1").Range("A:
A,J:
J").CopyRange("d1")
EndSub
选择2至4行
Sub选择2至4行()
DimaAsInteger
DimbAsInteger
a=2
b=4
Rows(a&":
"&b).Select
EndSub
在当前选区有条件替换数值为文本
Sub在当前选区有条
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel 常见 解析