Excel常见宏解析Word格式.docx
《Excel常见宏解析Word格式.docx》由会员分享，可在线阅读，更多相关《Excel常见宏解析Word格式.docx（74页珍藏版）》请在冰豆网上搜索。
Sub另存指定文件名（）
ActiveWorkbook.SaveAsThisWorkbook.Path&
"
\别名.xls"
以本工作表名称另存文件到当前目录
Sub以本工作表名称另存文件到当前目录（）
=ThisWorkbook.Path&
\"
ActiveSheet.Name&
.xls"
将本工作表单独另存文件到Excel当前默认目录
Sub将本工作表单独另存文件到Excel当前默认目录（）
ActiveSheet.Copy
ActiveWorkbook.SaveAsFilename:
=ActiveSheet.Name&
以活动工作表名称另存文件到Excel当前默认目录
Sub以活动工作表名称另存文件到Excel当前默认目录（）
FileFormat:
xlNormal,Password:
WriteResPassword:
ReadOnlyRecommended:
=False_
CreateBackup:
另存所有工作表为工作簿
Sub另存所有工作表为工作簿（）
DimshtAsWorksheet
Application.ScreenUpdating=False
ipath=ThisWorkbook.Path&
ForEachshtInSheets
sht.Copy
ActiveWorkbook.SaveAsipath&
sht.Name&
（工作表名称为文件名）
ActiveWorkbook.SaveAsipath&
Trim（sht.[d15]）&
（文件名称&
D15单元内容）
（文件名称为D15单元内容）
ActiveWorkbook.Close
Next
Application.ScreenUpdating=True
以指定单元内容为新文件名另存文件
Sub以指定单元内容为新文件名另存文件（）
ThisWorkbook.SaveAsFilename:
Sheet1.[A1]
以当前日期为新文件名另存文件
Sub以当前日期为新文件名另存文件（）
ThisWorkbook.SaveAsThisWorkbook.Path&
Format（Now（）,"
yyyymmdd"
）&
Sub以当前日期为名称另存文件（）
=Date&
以当前日期和时间为新文件名另存文件
Sub以当前日期和时间为新文件名另存文件（）
yyyy"
年"
mm"
月"
dd"
日"
h"
时"
分"
ss"
秒"
另存本表为TXT文件
Sub另存本表为TXT文件（）
DimsAsString
DimFullNameAsString,rngAsRange
Application.ScreenUpdating=False
FullName=（ActiveSheet.Name&
.txt"
）'
以当前表名为TXT文件名
'
FullName=Replace（ThisWorkbook.FullName,"
"
）'
以当前文件名为TXT文件名
ActiveSheet.Name&
以文件名&
表名为TXT文件名
OpenFullNameForOutputAs#1'
以读写方式打开文件，每次写内容都会覆盖原先的内容
参考帮助，fullname为文件全名
ForEachrngInRange（"
a1"
）.CurrentRegion
s=s&
IIf（s="
|"
rng.Value
Ifrng.Column=Range（"
）.CurrentRegion.Columns.CountThen
Print#1,s&
把数据写到文本文件里
s="
Close#1'
关闭文件
Application.ScreenUpdating=True
数据已导入文本"
引用指定位置单元内容为部分文件名另存文件
Sub引用指定位置单元内容为部分文件名另存文件（）
解答"
Range（"
sheet1!
郎雀.xls"
将A列数据排序到D列
Sub将A列数据排序到D列（）
[d:
d]=[a:
a].Value
d].SortKey1:
=Range（"
D1"
）,Order1:
=xlAscending,Header:
=xlYes
将指定范围的数据排列到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（"
）.Resize（i,1）=arr2
光标移动
Sub光标移动（）
ActiveCell.Offset（1,2）.Select'
向下移动1行，向右移动2列
光标所在行上移一行
Sub光标所在行上移一行（）
Dimi%
i=Split（ActiveCell.Address,"
$"
）
（2）
Ifi>
1Then
Rows（i）.Cut
Rows（i-1）.InsertShift:
=xlDown
加数据有效限制
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
取消数据有效限制
Sub取消数据有效限制（）
=xlValidateInputOnly,AlertStyle:
=xlValidAlertStop,Operator_
:
=xlBetween
重排窗口
Sub重排窗口（）
Web"
我的工具"
Windows.ArrangeArrangeStyle:
=xlCascade
按当前单元文本选择打开指定文件单元
Sub选择打开文件单元（）
Dima
a=ActiveCell.Value
Range（a）.Worksheet.Activate
Range（a）.Select
回车光标向右
Sub录入光标向右（）
Application.MoveAfterReturnDirection=xlToRight
回车光标向下
Sub录入光标向下（）
Application.MoveAfterReturnDirection=xlDown
保护工作表时取消选定锁定单元
Sub取消选定锁定单元（）
ActiveSheet.EnableSelection=xlUnlockedCells'
用于2000版
保存并退出Excel
Sub保存并退出Excel（）
Application.SendKeys（"
{ENTER}{ENTER}%fx"
ActiveWorkbook.Save
隐藏/显示指定列空值行
Sub隐藏显示E列空值行（）
E1:
E1000"
）.SpecialCells（xlCellTypeBlanks）.EntireRow.Hidden=Not（Range（"
）.SpecialCells（xlCellTypeBlanks）.EntireRow.Hidden）
深度隐藏指定工作表
Sub深度隐藏指定工作表（）
Sheets（"
用户名密码"
）.Visible=xlVeryHidden
隐藏指定工作表
Sub隐藏指定工作表（）
）.Visible=false
隐藏当前工作表
Sub隐藏当前工作表（）
ActiveWindow.SelectedSheets.Visible=false
返回当前工作表名称
Sub返回当前工作表名称（）
wsName=ActiveSheet.Name
MsgBox"
当前工作表为：
wsName
获取上一次所进入工作簿的工作表名称
Sub获取上一次所进入工作簿的工作表名称（）
MsgBoxWorkbooks
（2）.ActiveSheet.Name
按光标选定颜色隐藏本列其他颜色行
Sub按颜色筛选（）'
思路就是:
其它背景色之行全部隐藏
DimUseRow,AC,i'
首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏
UseRow=Cells.SpecialCells（xlCellTypeLastCell）.Row'
SpecialCells（xlCellTypeLastCell）表示已用区域最后一个单元格
IfActiveCell.Row>
UseRowThen
请在要筛选的区域选择一个有颜色之单元格！
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
打开工作簿自动隐藏录入表以外的其他表
PrivateSubWorkbook_Open（）
Dimi
Fori=1ToSheets.Count
IfSheets（i）.Name<
录入"
Then
Sheets（i）.Visible=False
除最左边工作表外深度隐藏所有表
Sub除最左边工作表外深度隐藏所有表（）
Fori=2ToThisWorkbook.Sheets.Count
Sheets（i）.Visible=xlSheetVeryHidden
关闭文件时自动隐藏指定工作表（ThisWorkbook）
PrivateSubWorkbook_BeforeClose（CancelAsBoolean）
ActiveWorkbook.Unprotect
Sheets（"
Sheet2"
Sheet3"
ActiveWorkbook.ProtectStructure:
=True,Windows:
打开文件时提示指定工作表是保护状态（ThisWorkbook）
IfWorksheets（"
Sheet1"
）.ProtectContents=TrueThen
Sheet1保护了."
插入10行
Sub插入10行（）
Rows（ActiveCell.Row&
:
ActiveCell.Row+9）.Select
Selection.InsertShift:
全选固定范围内小于0的单元
Sub全选固定范围内小于0的单元（）
DimrngAsRange
Dimyvhf
ForEachrngInRange（"
d6:
i18"
Ifrng<
0Then
yvhf=yvhf&
rng.Address&
"
Range（Left（yvhf,Len（yvhf）-1））.Select
全选选定范围内小于0的单元
Sub全选选定范围内小于0的单元（）
ForEachrngInSelection
固定区域单元分类变色
Sub单元分类变色（）
rng.Interior.ColorIndex=4'
小于0的单元变绿底色
Ifrng>
rng.Interior.ColorIndex=3'
文本、假空和大于0的单元变红底色
Ifrng=0Then
rng.Interior.ColorIndex=2'
空值和等于0的单元变白底色
A列半角内容变红
SubA列半角内容变红（）
DimrgAsRange,iAsLong
ForEachrgInCells.SpecialCells（xlCellTypeConstants,3）
Fori=1ToLen（rg）
IfAsc（Mid（rg,i,1））>
0Thenrg.Characters（i）.Font.ColorIndex=3
单元格录入数据时运行宏的代码
PrivateSubWorksheet_Change（ByValTargetAsRange）
焦点到A列时运行宏的代码
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
IfTarget.Column=1Then
宏名
根据B列最后数据快速合并A列单元格的控件代码
PrivateSubCommandButton1_Click（）
Fori=1To[b65536].End（xlUp）.Row
Forj=i+1To[b65536].End（xlUp）.Row
IfRange（"
a"
j）="
i&
j）.Merge
Else
ExitFor
Nextj
Nexti
在F1单元显示光标位置批注内容的代码
a=Selection.Address
b=Range（a）.NoteText
Cells（1,6）=b
显示光标所在单元的批注的代码
DimrAsRange
OnErrorResumeNext
r.Comment.Visible=False
Setr=Target
r.Comment.Visible=True
使单元内容保持不变的工作表代码
[B2]="
不可更改的数据"
有条件执行宏
Sub高级筛选（）
If[J1]=2Or[K1]="
筛选"
Columns（"
D:
E"
）.Select
Selection.Clear
A:
B"
）.AdvancedFilterAction:
=xlFilterCopy,CriteriaRange:
=Range（_
G1:
G2"
）,CopyToRange:
）,Unique:
有条件执行不同的宏
Sub有条件执行不同的宏（）
If[b1].Value="
A"
Application.Run"
宏1"
ElseIf[b1].Value="
宏2"
提示确定或取消执行宏
Sub提示确定或取消执行宏（）
IfvbOK=MsgBox（"
确定要复制吗?
vbOKCancel）Then
A4:
A14"
）.CopyRange（"
b4:
b14"
Msgbox"
复制结束"
提示开始和结束
Sub提示结束（）
运行开始"
过程……
运行结束"
拷贝指定表不相邻多列数据到新位置
Sub拷贝指定表不相邻多列数据到新位置（）
sheet1"
）.Range（"
A,J:
J"
d1"
选择2至4行
Sub选择2至4行（）
DimaAsInteger
DimbAsInteger
a=2
b=4
Rows（a&
b）.Select
在当前选区有条件替换数值为文本
Sub在当前选区有条
升级会员 