实用excel宏代码精华版Word文档格式.docx
《实用excel宏代码精华版Word文档格式.docx》由会员分享，可在线阅读，更多相关《实用excel宏代码精华版Word文档格式.docx（8页珍藏版）》请在冰豆网上搜索。
ActiveSheet.Paste
A:
A"
）.RemoveDuplicates
（1）
Sheets（"
）.Visible=False
Fori=2ToApplication.WorksheetFunction.CountA（Sheets（"
）.Range（"
））
Sheets（h）.Activate
ActiveSheet.UsedRange.AutoFilterField:
=m,Criteria1:
=Sheets（"
）.Cells（i,1）
Sheets（h）.UsedRange.Copy
Sheets.AddAfter:
ActiveSheet.Paste
ActiveSheet.Name=Sheets（"
Sheets（h）.Select
Next
Selection.AutoFilter
Application.DisplayAlerts=False
）.Delete
Application.DisplayAlerts=True
----------------------------------------
Sub重命名活动工作簿（）
'
如果利用DIR提取的活动工作簿的名称长度为0（即未保存），那么提示用户，然后退出程序
IfLen（Dir（ActiveWorkbook.FullName））=0ThenMsgBox"
请先保存工作簿"
vbOKOnly,"
友情提示"
:
ExitSub
Dim原名称AsString,新名称AsString,后缀名AsString,路径AsString'
声明变量
原名称=ActiveWorkbook.Name'
提取活动工作簿名称
后缀名=StrReverse（Mid（StrReverse（原名称）,1,InStr（StrReverse（原名称）,"
."
）））'
提取活动工作簿的后缀名
新名称=Application.InputBox（"
请输入文件名"
"
新名称"
Replace（原名称,后缀名,"
"
）,,,,,2）'
弹出输入框让用户输入新的名称
If新名称="
False"
ThenEnd'
如果选择了取消键则结束过程
路径=Replace（ActiveWorkbook.FullName,原名称,"
）'
提取活动工作簿的路径
OnErrorResumeNext'
当有错误时继续执行
MkDir"
C:
\"
&
新名称'
在C盘创建一个同名的文件夹（测试字符串能否作为文件名称）
IfErr<
>
0Then'
如果有错误
MsgBox"
您输入的字符不允许作为文件名，请重新输入！
提示
Else'
否则
RmDir"
删除创建的文件夹
ActiveWorkbook.SaveAs路径&
新名称&
后缀名'
将活动工作簿另存为指定的名称（与原文件相同路径下）
Kill路径&
原名称'
删除原来的文件
EndIf
---------------------------------------------------
PublicSub工作表保护密码破解（）
ConstDBLSPACEAsString=vbNewLine&
vbNewLine
ConstAUTHORSAsString=DBLSPACE&
vbNewLine&
_
作者:
McCormickJEMcGimpsey"
ConstHEADERAsString="
工作表保护密码破解"
ConstVERSIONAsString=DBLSPACE&
"
版本Version1.1.1"
ConstREPBACKAsString=DBLSPACE&
ConstZHENGLIAsString=DBLSPACE&
hfhzi3—戊冥整理"
ConstALLCLEARAsString=DBLSPACE&
该工作簿中的工作表密码保护已全部解除!
!
DBLSPACE&
请记得另保存"
&
注意：
不要用在不当地方，要尊重他人的劳动成果！
ConstMSGNOPWORDS1AsString="
该文件工作表中没有加密"
ConstMSGNOPWORDS2AsString="
该文件工作表中没有加密2"
ConstMSGTAKETIMEAsString="
解密需花费一定时间,请耐心等候!
按确定开始破解!
ConstMSGPWORDFOUND1AsString="
密码重新组合为:
$$"
如果该文件工作表有不同密码,将搜索下一组密码并修改清除"
ConstMSGPWORDFOUND2AsString="
如果该文件工作表有不同密码,将搜索下一组密码并解除"
ConstMSGONLYONEAsString="
确保为唯一的?
Dimw1AsWorksheet,w2AsWorksheet
DimiAsInteger,jAsInteger,kAsInteger,lAsInteger
DimmAsInteger,nAsInteger,i1AsInteger,i2AsInteger
Dimi3AsInteger,i4AsInteger,i5AsInteger,i6AsInteger
DimPWord1AsString
DimShTagAsBoolean,WinTagAsBoolean
Application.ScreenUpdating=False
WithActiveWorkbook
WinTag=.ProtectStructureOr.ProtectWindows
EndWith
ShTag=False
ForEachw1InWorksheets
ShTag=ShTagOrw1.ProtectContents
Nextw1
IfNotShTagAndNotWinTagThen
MsgBoxMSGNOPWORDS1,vbInformation,HEADER
ExitSub
EndIf
MsgBoxMSGTAKETIME,vbInformation,HEADER
IfNotWinTagThen
Else
OnErrorResumeNext
Do'
dummydoloop
Fori=65To66:
Forj=65To66:
Fork=65To66
Forl=65To66:
Form=65To66:
Fori1=65To66
Fori2=65To66:
Fori3=65To66:
Fori4=65To66
Fori5=65To66:
Fori6=65To66:
Forn=32To126
.UnprotectChr（i）&
Chr（j）&
Chr（k）&
Chr（l）&
Chr（m）&
Chr（i1）&
Chr（i2）&
Chr（i3）&
Chr（i4）&
Chr（i5）&
Chr（i6）&
Chr（n）
If.ProtectStructure=FalseAnd_
.ProtectWindows=FalseThen
PWord1=Chr（i）&
Chr（l）&
Chr（m）&
Chr（i3）&
Chr（i4）&
MsgBoxApplication.Substitute（MSGPWORDFOUND1,_
PWord1）,vbInformation,HEADER
ExitDo'
Bypassallfor...nexts
Next:
Next:
LoopUntilTrue
OnErrorGoTo0
IfWinTagAndNotShTagThen
MsgBoxMSGONLYONE,vbInformation,HEADER
'
AttemptclearancewithPWord1
w1.UnprotectPWord1
ChecksforallclearShTagtriggeredto1ifnot.
IfShTagThen
Withw1
If.ProtectContentsThen
Dummydoloop
IfNot.ProtectContentsThen
MsgBoxApplication.Substitute（MSGPWORDFOUND2,_
leveragefindingPwordbytryingonothersheets
ForEachw2InWorksheets
w2.UnprotectPWord1
Nextw2
MsgBoxALLCLEAR&
AUTHORS&
VERSION&
REPBACK&
ZHENGLI,vbInformation,HEADER
Sub关闭所有工作簿（）
Workbooks.Close
Sub将一个工作簿内的多个工作表拆分为一个个独立的工作簿（）
DimshtAsWorksheet
DimMyBookAsWorkbook
SetMyBook=ActiveWorkbook
ForEachshtInMyBook.Sheets
sht.Copy
ActiveWorkbook.SaveAsFileName:
=MyBook.Path&
sht.Name,FileFormat:
=xlNormal'
将工作簿另存为EXCEL默认格式
ActiveWorkbook.Close
文件已经被分拆完毕!
EndSub
---------------------------------------------------Sub所选单元格数值单位转换为万显示（）
格式万宏
快捷键:
Ctrl+Shift+Z
Selection.NumberFormatLocal="
0!
.0,万"
Sub提取所有工作表名称（）
Dimx
Forx=1ToSheets.Count
Cells（x,1）=Sheets（x）.Name
Nextx
升级会员 