实用excel宏代码精华版.docx

资源描述

实用excel宏代码精华版.docx

《实用excel宏代码精华版.docx》由会员分享，可在线阅读，更多相关《实用excel宏代码精华版.docx（8页珍藏版）》请在冰豆网上搜索。

实用excel宏代码精华版.docx

实用excel宏代码精华版

非常实用excel宏代码

代码功能包含：

显示所有隐藏工作表，按指定列拆分工作表，将一个工作簿内的多个工作表拆分为一个个独立的工作簿，在工作簿打开的状态下直接重命名活动工作簿，工作表保护密码破解，一次性关闭所有工作簿，将所选单元格数值单位转换为万显示，一次性提取所有工作表名称等

--------------------------------------------------

Sub显示所有隐藏工作表（）

ForEachStInSheets

IfSt.Visible=FalseThenSt.Visible=True

EndSub

-------------------------------------------

Sub按指定列拆分工作表（）

Dimi%,m%,h$

h=ActiveSheet.Name

Range（"a1"）.Select

m=InputBox（"请输入列数"）

Columns（m）.Copy

Worksheets.AddAfter:

=Sheets（Sheets.Count）

ActiveSheet.Name="B"

Range（"A1"）.Select

ActiveSheet.Paste

Range（"A:

A"）.RemoveDuplicates

（1）

Sheets（"B"）.Visible=False

Fori=2ToApplication.WorksheetFunction.CountA（Sheets（"B"）.Range（"A:

A"））

Sheets（h）.Activate

ActiveSheet.UsedRange.AutoFilterField:

=m,Criteria1:

=Sheets（"B"）.Cells（i,1）

Sheets（h）.UsedRange.Copy

Sheets.AddAfter:

=Sheets（Sheets.Count）

ActiveSheet.Paste

ActiveSheet.Name=Sheets（"B"）.Cells（i,1）

Sheets（h）.Select

Selection.AutoFilter

Application.DisplayAlerts=False

Sheets（"B"）.Delete

Application.DisplayAlerts=True

EndSub

----------------------------------------

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"您输入的字符不允许作为文件名，请重新输入！

",vbOKOnly,"友情提示"'提示

Else'否则

RmDir"C:

\"&新名称'删除创建的文件夹

ActiveWorkbook.SaveAs路径&新名称&后缀名'将活动工作簿另存为指定的名称（与原文件相同路径下）

Kill路径&原名称'删除原来的文件

EndIf

EndSub

---------------------------------------------------

PublicSub工作表保护密码破解（）

ConstDBLSPACEAsString=vbNewLine&vbNewLine

ConstAUTHORSAsString=DBLSPACE&vbNewLine&_

"作者:

McCormickJEMcGimpsey"

ConstHEADERAsString="工作表保护密码破解"

ConstVERSIONAsString=DBLSPACE&"版本Version1.1.1"

ConstREPBACKAsString=DBLSPACE&""

ConstZHENGLIAsString=DBLSPACE&"hfhzi3—戊冥整理"

ConstALLCLEARAsString=DBLSPACE&"该工作簿中的工作表密码保护已全部解除!

"&DBLSPACE&"请记得另保存"_

&DBLSPACE&"注意：

不要用在不当地方，要尊重他人的劳动成果！

ConstMSGNOPWORDS1AsString="该文件工作表中没有加密"

ConstMSGNOPWORDS2AsString="该文件工作表中没有加密2"

ConstMSGTAKETIMEAsString="解密需花费一定时间,请耐心等候!

"&DBLSPACE&"按确定开始破解!

ConstMSGPWORDFOUND1AsString="密码重新组合为:

"&DBLSPACE&"$$"&DBLSPACE&_

"如果该文件工作表有不同密码,将搜索下一组密码并修改清除"

ConstMSGPWORDFOUND2AsString="密码重新组合为:

"&DBLSPACE&"$$"&DBLSPACE&_

"如果该文件工作表有不同密码,将搜索下一组密码并解除"

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

WithActiveWorkbook

.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（j）&Chr（k）&Chr（l）&_

Chr（m）&Chr（i1）&Chr（i2）&Chr（i3）&_

Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

MsgBoxApplication.Substitute（MSGPWORDFOUND1,_

"$$",PWord1）,vbInformation,HEADER

ExitDo'Bypassallfor...nexts

EndIf

EndWith

LoopUntilTrue

OnErrorGoTo0

EndIf

IfWinTagAndNotShTagThen

MsgBoxMSGONLYONE,vbInformation,HEADER

ExitSub

EndIf

OnErrorResumeNext

ForEachw1InWorksheets

'AttemptclearancewithPWord1

w1.UnprotectPWord1

Nextw1

OnErrorGoTo0

ShTag=False

ForEachw1InWorksheets

'ChecksforallclearShTagtriggeredto1ifnot.

ShTag=ShTagOrw1.ProtectContents

Nextw1

IfShTagThen

ForEachw1InWorksheets

Withw1

If.ProtectContentsThen

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）

IfNot.ProtectContentsThen

PWord1=Chr（i）&Chr（j）&Chr（k）&Chr（l）&_

Chr（m）&Chr（i1）&Chr（i2）&Chr（i3）&_

Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

MsgBoxApplication.Substitute（MSGPWORDFOUND2,_

"$$",PWord1）,vbInformation,HEADER

'leveragefindingPwordbytryingonothersheets

ForEachw2InWorksheets

w2.UnprotectPWord1

Nextw2

ExitDo'Bypassallfor...nexts

EndIf

LoopUntilTrue

OnErrorGoTo0

EndIf

EndWith

Nextw1

EndIf

MsgBoxALLCLEAR&AUTHORS&VERSION&REPBACK&ZHENGLI,vbInformation,HEADER

EndSub

---------------------------------------------------

Sub关闭所有工作簿（）

Application.DisplayAlerts=False

Workbooks.Close

Application.DisplayAlerts=True

EndSub

---------------------------------------------------

Sub将一个工作簿内的多个工作表拆分为一个个独立的工作簿（）

Application.DisplayAlerts=False

DimshtAsWorksheet

DimMyBookAsWorkbook

SetMyBook=ActiveWorkbook

ForEachshtInMyBook.Sheets

sht.Copy

ActiveWorkbook.SaveAsFileName:

=MyBook.Path&"\"&sht.Name,FileFormat:

=xlNormal'将工作簿另存为EXCEL默认格式

ActiveWorkbook.Close

Application.DisplayAlerts=True

MsgBox"文件已经被分拆完毕!

EndSub

---------------------------------------------------Sub所选单元格数值单位转换为万显示（）

'格式万宏

'快捷键:

Ctrl+Shift+Z

Selection.NumberFormatLocal="0!

.0,万"

EndSub

---------------------------------------------------

Sub提取所有工作表名称（）

Dimx

Forx=1ToSheets.Count

Cells（x,1）=Sheets（x）.Name

Nextx

EndSub

展开阅读全文