适用代码实例

第一部《VBA技巧应用》(作者：赵志东)第1章Excel文件与文件夹操作1.1返回当前Excel文件的路径Sub打开文件B()

DimMSTAsString

'声明变量

MST=ThisWorkbook.Path

'把当前文件的路径赋予MST

Workbooks.OpenMST&"\B.XLS"

'打开文件B

EndSub

Workbooks.Open路径+名称,打开指定工作薄

1.2返回指定文件夹中的文件列表

Sub列出所有文件名()

DimxlsFileAsString

'DIR(路径):此路径下的E文件名集合中的一成员

xlsFile=Dir(ActiveWorkbook.Path&"\*.XLS")

Do

'如文件名不含有"汇总",则

IfInStr(1,xlsFile,"汇总")=0Then

Cells(([A65536].End(xlUp).Row+1),1)=xlsFile

EndIf

xlsFile=Dir

'如果UNTIL条件成立,则跳出DO循环

LoopUntilLen(xlsFile)=0

EndSub

Dir[(pathname[,attributes])]，在第一次调用Dir函数时，必须指定pathname，否则会产生错误。如果也指定了文件属性，那么就必须包括pathname。Dir会返回匹配pathname的第一个文件名。若想得到其它匹配pathname的文件名，再一次调用Dir，且不要使用参数。如果已没有合乎条件的文件，则Dir会返回一个零长度字符串("")。一旦返回值为零长度字符串，并要再次调用Dir时，就必须指定pathname，否则会产生错误。不必访问到所有匹配当前pathname的文件名，就可以改变到一个新的pathname上。但是，不能以递归方式来调用Dir函数。以vbDirectory属性来调用Dir不能连续地返回子目录。

1.3判断文件夹中指定文件是否存在

Sub判断AAA文件是否存在()

SetFS=Application.FileSearch

'设FS为文件名称

WithFS

.LookIn=ThisWorkbook.Path'确定路径

.Filename="AAA.XLS"

'查找的文件名

If.Execute()>0Then

'判断查找的结果

MsgBox"AAA文件存在"

Else

MsgBox"AAA文件不存在"

EndIf

EndWith

EndSub

FileSearch属性：为文件搜索返回一个FileSearch对象。

LookIn属性：返回或设置在指定的文件搜索过程中要搜索的文件夹

FileName属性：返回或设置保存指定源对象位置的URL（Intranet或网站上）或路径（本地或网络）。String类型，可读写。

Execute方法：激活与单元格中智能标记类型相关的智能标记操作。语法：expression.Execute，expression

必需。该表达式返回“应用于”列表中的对象之一。

提取指定文件夹的EXCEL文件名称

Sub提取EXCEL文件名称()

Application.ScreenUpdating=False‘停止刷新

MC=ActiveWorkbook.Name

DimssAsWorkbook

WithApplication.FileSearch

.LookIn=Application.ThisWorkbook.Path+"\文件"

.Filename="*.xls"

If.Execute()>0Then

MsgBox"共有"&.FoundFiles.Count&"个需要读取的文件。",,"读取EXCEL文件名"

Fori=1To.FoundFiles.Count

Setss=Workbooks.Open(.FoundFiles(i),,ReadOnly)

x=Workbooks(MC).Sheets("Sheet4").[A65536].End(xlUp).Row

bw=InStr(1,ss.Name,".")

bs=Left(ss.Name,bw-1)

Workbooks(MC).Sheets("Sheet4").Cells(x+1,1)=bs

Workbooks(ss.Name).CloseSaveChanges:=False

Nexti

Else

MsgBox"文件文件夹中没有需要读取的文件。",,"读取EXCEL文件名"

EndIf

EndWith

Application.ScreenUpdating=True

EndSub

FoundFiles属性:返回一个FoundFiles对象，该对象包括一次查找操作中找到的所有文件的文件名。只读。FoundFiles对象参阅属性方法事件特性代表由文件查找过程返回的文件列表。使用FoundFiles对象用FoundFiles属性可返回FoundFiles对象。本示例可实现：逐个查看找到的文件列表中的文件并显示其中每个文件的文件名和路径。用FoundFiles(index)可返回查找过程中指定文件的名称和位置，此处的index是该文件的索引号。

1.4在文件夹之间复制和移动Excel文件

Sub复制表1()

FileCopyThisWorkbook.Path&"/表1.XLS",ThisWorkbook.Path&"/目标/表1.XLS"

EndSub

Sub移动表2()

FileCopyThisWorkbook.Path&"/表2.XLS",ThisWorkbook.Path&"/目标/表2.XLS"

KillThisWorkbook.Path&"/表2.XLS"

EndSub

注释１：

FileCopy语句:复制一个文件。

语法:FileCopysource,destination

FileCopy语句的语法含有以下这些命名参数的描述

source必要参数。字符串表达式，用来表示要被复制的文件名。source可以包含目录或文件夹、以及驱动器。

destination必要参数。字符串表达式，用来指定要复制的目地文件名。destination可以包含目录或文件夹、以及驱动器。

说明:如果想要对一个已打开的文件使用FileCopy语句，则会产生错误。

注释２：

Kill语句:从磁盘中删除文件。

语法:Killpathname

必要的pathname参数是用来指定一个文件名的字符串表达式。pathname可以包含目录或文件夹、以及驱动器。

说明:在MicrosoftWindows中，Kill支持多字符(*)和单字符(?)的统配符来指定多重文件。.

如果使用Kill来删除一个已打开的文件，则会产生错误。

注意若要删除目录，使用RmDir语句

1.5判断指定文件夹是否存在

Sub判断文件夹是否存在()

SetYYY=CreateObject("Scripting.FileSystemObject")

'设YYY为文件夹对象变量

IfYYY.FolderExists(ThisWorkbook.Path&"\A")=TrueThen

MsgBox"A文件夹存在"

Else

MsgBox"A文件夹不存在"

MkDirThisWorkbook.Path&"\A"

EndIf

SetYYY=Nothing

EndSub

注释１：

FileExists(路径+文件名)：检验文件是否存在，返回true,false

注释２：

MkDir语句:创建一个新的目录或文件夹。

语法:MkDirpath

必要的path参数是用来指定所要创建的目录或文件夹的字符串表达式。path可以包含驱动器。如果没有指定驱动器，则MkDir会在当前驱动器上创建新的目录或文件夹。

Scripting.FileSystemObject需添加引用的“MIscosoftscriptingruntime”，

1.6列示所有子文件夹名称

SubShowFolderList()

'运行cmd命令

'注消FSO组件：RegSvr32/u%windir%\SYSTEM32\scrrun.dll

'启用FSO命令：RegSvr32%windir%\SYSTEM32\scrrun.dll

Dimfs,f,f1,fc,s

Setfs=CreateObject("Scripting.FileSystemObject")

'创建FileSystemObject对象

Setf=fs.GetFolder(ThisWorkbook.Path)

'创建文件夹对象

Setfc=f.SubFolders

'取得文件夹集合

ForEachf1Infc

s=s&f1.Name

s=s&vbCrLf

'在每个文件夹名后加回车和换行符

Next

MsgBoxs

EndSub

注释１：

GetFolder(路径)取得目录对象

注释２：

SubFolders属性:返回一个Folders集合，由指定文件夹中包含的所有文件夹组

成，包括设置了隐藏和系统文件属性的文件夹。object.SubFoldersobject应

为Folder对象

1.7文件夹的复制和移动

Sub复制A文件夹到C()

Dimf,fs

Setfs=CreateObject("Scripting.FileSystemObject")

Setf=fs.GetFolder(ThisWorkbook.Path&"\A")'得到folder对象

f.Copy(ThisWorkbook.Path&"\C\")

'复制文件夹

MsgBox"复制成功!"

EndSub

Sub移动B文件夹到C()

Dimf,fs

Setfs=CreateObject("Scripting.FileSystemObject")

Setf=fs.GetFolder(ThisWorkbook.Path&"\B")'得到folder对象

f.Move(ThisWorkbook.Path&"\C\")

'移动文件夹

MsgBox"移动成功!"

EndSub

注释１：

Move方法:将指定工作表移到工作簿的另一位置。

语法:expression.Move(Before,After)

expression

必需。该表达式返回“应用于”列表中的对象之一。

Before

Variant类型，可选。表示某工作表，欲移动的工作表将移到此工作表之前。如果已经指定了After，则不能指定Before。

After

Variant类型，可选。表示某工作表，欲移动的工作表将移到此工作表之后。如果已经指定了Before，则不能指定After。

说明：如果既不指定Before参数也不指定After参数，则MicrosoftExcel将新建一个工作簿并将欲移动的工作表移到新工作簿中。

示例：本示例将Sheet1移到当前活动工作簿的Sheet3之后。

Worksheets("Sheet1").Move_

after:=Worksheets("Sheet3")

1.8批量删除文件夹

Sub批量删除文件夹()

Dimfs,f,f1,fc

Setfs=CreateObject("Scripting.FileSystemObject")

'创建FileSystemObject对象

Setf=fs.GetFolder(ThisWorkbook.Path)

'创建指定路径文件夹对象

Setfc=f.SubFolders

'取得文件夹集合

ForEachf1Infc

IfInStr(1,f1.Name,"A")>0Then

'判断文件夹名称中是否包含字符A

f1.Delete

'删除文件夹

MsgBox"删除成功"

EndIf

Nextf1

EndSub

注释１：

InStr函数：返回Variant(Long)，指定一字符串在另一字符串中最先出现的位置。

语法：InStr([start,]string1,string2[,compare])

InStr函数的语法具有下面的参数：

部分说明

start可选参数。为数值表达式，设置每次搜索的起点。如果省略，将从第一个字符的位置开始。如果start包含Null，将发生错误。如果指定了compare参数，则一定要有start参数。

string1必要参数。接受搜索的字符串表达式。

string2必要参数。被搜索的字符串表达式。

Compare可选参数。指定字符串比较。如果compare是Null，将发生错误。如果省略compare，OptionCompare的设置将决定比较的类型。指定一个有效的LCID(LocaleID)以在比较中使用与区域有关的规则。

compare参数设置为：

常数值描述

vbUseCompareOption-1使用OptionCompare语句设置执行一个比较。

vbBinaryCompare0执行一个二进制比较。

vbTextCompare1执行一个按照原文的比较。

vbDatabaseCompare2仅适用于MicrosoftAccess，执行一个基于数据库中信息的比较。

返回值：如果InStr返回；string1为零长度0；string1为NullNullstring2为零长度Start；string2为NullNull

string2找不到0；在string1中找到string2

找到的位置；start>string20

说明

InStrB函数作用于包含在字符串中的字节数据。所以InStrB返回的是字节位置，而不是字符位置。

1.9获取文件夹大小

Sub获取文件夹信息()

Setfs=CreateObject("Scripting.FileSystemObject")

Setf=fs.GetFolder(ThisWorkbook.Path&"\A\")

'创建文件夹对象

S=f.Name&"文件夹的大小为"&FormatNumber(f.Size/1024,0)&"KB"&vbCrLf

'得到文件夹大小,vbCrLf是换行符

MsgBoxS

EndSub

注释１：

FormatNumber函数：返回一个数字格式的表达式。

语法：FormatNumber(Expression[,NumDigitsAfterDecimal[,IncludeLeadingDigit[,UseParensForNegativeNumbers[,GroupDigits]]]])

FormatNumber函数语法有如下几部分：

部分描述

Expression必需的。要被格式化的表达式。

NumDigitsAfterDecimal可选的。数字值，表示小数点右边的显示位数。缺省值为–1，表示使用计算机的区域设置值。

IncludeLeadingDigit可选的。三态常数，表示小数点前是否显示零。关于其值，请参阅“设置值”部分。

UseParensForNegativeNumbers可选的。三态常数，表示是否把负数值放在圆括号内。关于其值，请参阅“设置值”部分。

GroupDigits可选的。的三态常数，表示是否用组分隔符对数字分组，组分隔符在计算机的区域设置值中指定。关于其值，请参阅“设置值”部分。

设置值

IncludeLeadingDigit、UseParensForNegativeNumbers和GroupDigits参数的设置值如下：

常数值描述

vbTrue–1True

vbFalse0False

vbUseDefault–2用计算机区域设置值中的设置值。

说明：当忽略一个或多个选项参数时，被忽略的参数值由计算机的区域设置值提供。

注意

所有设置值信息都来自“区域设置”的“数字”选项卡。

1-19用U盘系列号做工作薄打开密码

PrivateSubWorkbook_Open()

CallU盘锁代码

EndSub

SubU盘锁代码()

Dimfs,d,s$

OnErrorResumeNext

Fori=3To26‘26个字母

Setfs=CreateObject("scripting.filesystemobjEct")

Setd=fs.getdrive(Chr(64+i)&":")

s=d.SERIALNUMBER‘取得驱动器的系列号

SelectCases

Case"134374432"'U盘系列号

MsgBox"成功打开"

ExitSub

EndSelect

Setfs=Nothing

Setd=Nothing

Next

ThisWorkbook.CloseFalse

EndSub

注释1：

注释2：

Workbook.Close方法：关闭对象。

语法：表达式.Close(SaveChanges,Filename,RouteWorkbook)

表达式

一个代表Workbook对象的变量。

参数

名称必选/可选数据类型描述

SaveChanges可选Variant如果工作簿中没有改动，则忽略此参数。如果工作簿中有改动但工作簿显示在其他打开的窗口中，则忽略此参数。如果工作簿中有改动且工作簿未显示在任何其他打开的窗口中，则由此参数指定是否应保存更改。如果设为True，则保存对工作簿所做的更改。如果工作簿尚未命名，则使用FileName。如果省略Filename，则要求用户提供文件名。

Filename可选Variant以此文件名保存所做的更改。

RouteWorkbook可选Variant如果工作簿不需要传送给下一个收件人（没有传送名单或已经传送），则忽略此参数。否则，MicrosoftExcel根据此参数的值传送工作簿。如果设为True，则将工作簿传送给下一个收件人。如果设为False，则不发送工作簿。如果忽略，则要求用户确认是否发送工作簿。

说明：从VisualBasic关闭工作簿并不运行该工作簿中的任何Auto_Close宏。使用RunAutoMacros方法可运行自动关闭宏。

示例：此示例关闭Book1.xls，并放弃所有对此工作簿的更改。

VisualBasicforApplications

Workbooks("BOOK1.XLS").CloseSaveChanges:=False

获取所有磁盘序列

Sub获取所有磁盘序列号()

Dimfs,d,aaAsString,bAsString,cAsString

Setfs=CreateObject("Scripting.FileSystemObject")

OnErrorResumeNext

Fori=1To26

bb:

aa="ABCDEFGHIJKLMNOPQRSTUVWXYZ"

b=Mid(aa,i,1)

Setd=fs.getdrive(fs.GetDriveName(fs.GetAbsolutePathName(b&":")))

IfErr.Number=68Then

s=b&":盘未准备好"

Err.Clear

GoToaa

EndIf

SelectCased.DriveType

Case0:t="Unknown"

Case1:t="Removable"

Case2:t="Fixed"

Case3:t="Network"

Case4:t="CD-ROM"

Case5:t="RAMDisk"

EndSelect

s="磁盘:"&d.DriveLetter&"

类型:"&t&"

序列号:"&d.SERIALNUMBER

aa:

c=c&s&Chr(10)

Nexti

MsgBoxc,64,"andysky提示你"

EndSub

改进型U盘锁保护

SubU盘锁()

Dimfs,s$

OnErrorResumeNext

Setfs=CreateObject("scripting.filesystemobjEct")

ForEachDRIInfs.DRIVES

s=DRI.SERIALNUMBER

Ifs="134374432"Then'U盘系列号

MsgBox"打开成功"

Setfs=Nothing

ExitSub

EndIf

Next

Setfs=Nothing

MsgBox"打开失败"

ThisWorkbook.CloseFalse

EndSub

1.10用程序打开指定文件夹

Sub打开指定文件夹()

DimRet

Ret=Shell(＂explorer.exe＂&ThisWorkbook.Path&"\A\",vbNormalFocus)

EndSub

Shell函数：执行一个可执行文件，返回一个Variant(Double)，如果成功的话，代表这个程序的任务ID，若不成功，则会返回0。

语法：Shell(pathname[,windowstyle])

Shell函数的语法含有下面这些命名参数：

部分描述

pathname必要参数。Variant(String)，要执行的程序名，以及任何必需的参数或命令行变量，可能还包括目录或文件夹，以及驱动器。在Macintosh中，可以使用MacID函数来指定一个应用程序的署名而不是名称。下面的例子使用了MicrosoftWord的署名:ShellMacID("MSWD")

Windowstyle可选参数。Variant(Integer)，表示在程序运行时窗口的样式。如果windowstyle省略，则程序是以具有焦点的最小化窗口来执行的。在Macintosh（系统7.0或更高）中，windowstyle仅决定当应用程序运行时是否获得焦点。

windowstyle命名参数有以下这些值：

常量值描述

vbHide0窗口被隐藏，且焦点会移到隐式窗口。常数vbHide在Macintosh平台不可用。

VbNormalFocus1窗口具有焦点，且会还原到它原来的大小和位置。

VbMinimizedFocus2窗口会以一个具有焦点的图标来显示。

VbMaximizedFocus3窗口是一个具有焦点的最大化窗口。

VbNormalNoFocus4窗口会被还原到最近使用的大小和位置，而当前活动的窗口仍然保持活动。

VbMinimizedNoFocus6窗口会以一个图标来显示。而当前活动的的窗口仍然保持活动。

说明

如果Shell函数成功地执行了所要执行的文件，则它会返回程序的任务ID。任务ID是一个唯一的数值，用来指明正在运行的程序。如果Shell函数不能打开命名的程序，则会产生错误。

在Macintosh中，vbNormalFocus、vbMinimizedFocus和vbMaximizedFocus都将应用程序置于前台；vbHide、vbNoFocus、vbMinimizeFocus都将应用程序置于后台。

注意缺省情况下，Shell函数是以异步方式来执行其它程序的。也就是说，用Shell启动的程序可能还没有完成执行过程，就已经执行到Shell函数之后的语句。

1.11用程序创建桌面快捷方式

Sub创建桌面快捷方式()

DimmyPath

AsString

SetmyWshc=CreateObject("Wscript.Shell")

myPath=myWshc.SpecialFolders("Desktop")

'指定快捷方式名称

SetmySht=myWshc.CreateShortcut(myPath&"\我的快捷方式.lnk")

WithmySht

.TargetPath=ThisWorkbook.FullName

'指定档案的路径

.IconLocation=ThisWorkbook.Path&"\SS.ICO"

'设定图标

.Save

EndWith

SetmySht=Nothing

SetmyWshc=Nothing

EndSub

1.12判断指定Excel文件是否打开

Sub判断A文件是否已打开()

DimXAsInteger,YAsInteger

X=Workbooks.Count

'得到已打开的工作簿数量

ForY=1ToX

'在所有工作簿之间进行循环

IfWorkbooks(X).Name="A.xls"Then

'判断工作簿名称是否为"A.xls"

MsgBox"A文件已打开"

ExitSub

EndIf

NextY

MsgBox"A文件没有打开"

EndSub1.13Excel文件打开时播放音乐

PrivateDeclareFunctionPlaySoundLib"winmm.dll"Alias"PlaySoundA"(ByVallpszNameAsString,ByValhModuleAsLong,ByValdwFlagsAsLong)AsLong

PrivateSubWorkbook_Open()

CallPlaySound(ThisWorkbook.Path&"\启动.wav",0&,&H1)

EndSub

1.14定时“自杀”的Excel文件

PrivateSubWorkbook_Open()

IfNow()>=#9/15/2006#Then‘时间格式必须在前后加“#”号

ActiveWorkbook.ChangeFileAccessxlReadOnly

KillActiveWorkbook.FullName

Application.Quit

EndIf

EndSub

Workbook.ChangeFileAccess方法：更改工作簿的访问权限。本方法需要从磁盘加载工作簿的更新版本。

语法：表达式.ChangeFileAccess(Mode,WritePassword,Notify)

表达式

一个代表Workbook对象的变量。

参数

名称必选/可选数据类型描述

Mode必选XlFileAccess指定新的访问模式。

WritePassword可选Variant如果文件设置了写保护并且Mode为xlReadWrite，则指定写保护密码。如果文件没有密码或Mode为xlReadOnly，则忽略此参数。

Notify可选Variant如果该值为True（或省略该参数），则当无法立即访问文件时通知用户。

说明：如果以只读模式打开文件，则不可独占访问此文件。如果将此文件从只读更改为可读写，MicrosoftExcel必须载入该文件的新副本以确认在以只读模式打开该文件后没有进行过更改。

示例：本示例将活动工作簿设为只读。

VisualBasicforApplications

ActiveWorkbook.ChangeFileAccessMode:=xlReadOnly

1.15限制Excel文件使用的次数

PrivateSubWorkbook_Open()

AAA=GetSetting(appname:="MyApp",section:="Startup",key:="使用次数",Default:=1)

MsgBox"你还可以使用的次数为"&(20-AAA)&"次,请尽快和作者联系!"

IfAAA=20Then

DeleteSetting"MyApp","Startup"

MsgBox"系统将被删除,感谢您的试用!再见"

ActiveWorkbook.ChangeFileAccessxlReadOnly

KillActiveWorkbook.FullName

ThisWorkbook.CloseFalse

EndIf

AAA=AAA+1

SaveSetting"MyApp","Startup","使用次数",AAA

EndSub

参见实例三_54

1.16批量创建Excel文件

Sub批量创建Excel文件()

Application.ScreenUpdating=False

DimMBOOKAsWorkbook,acbookAsWorkbook

DimxAsInteger

mypath=ThisWorkbook.Path

Setacbook=ThisWorkbook

Forx=2To13

SetMBOOK=Workbooks.Add

MBOOK.SaveAsmypath&"\"&acbook.Sheets("sheet1").Cells(x,1)&".xls"

MBOOK.Close

Nextx

MsgBox"创建成功"

Application.ScreenUpdating=False

ENDSUB

Workbook.SaveAs方法：在另一不同文件中保存对工作簿所做的更改。

语法:表达式.SaveAs(FileName,FileFormat,Password,WriteResPassword,ReadOnlyRecommended,CreateBackup,AccessMode,ConflictResolution,AddToMru,TextCodepage,TextVisualLayout,Local)

表达式

一个代表Workbook对象的变量。

参数

名称必选/可选数据类型描述

Filename可选Variant一个表示要保存文件的文件名的字符串。可包含完整路径，如果不指定路径，MicrosoftExcel将文件保存到当前文件夹中。

FileFormat可选Variant保存文件时使用的文件格式。要查看有效的选项列表，请参阅FileFormat属性。对于现有文件，默认采用上一次指定的文件格式；对于新文件，默认采用当前所用Excel版本的格式。

Password可选Variant它是一个区分大小写的字符串（最长不超过15个字符），用于指定文件的保护密码。

WriteResPassword可选Variant一个表示文件写保护密码的字符串。如果文件保存时带有密码，但打开文件时不输入密码，则该文件以只读方式打开。

ReadOnlyRecommended可选Variant如果为True，则在打开文件时显示一条消息，提示该文件以只读方式打开。

CreateBackup可选Variant如果为True，则创建备份文件。

AccessMode可选XlSaveAsAccessMode工作簿的访问模式。

ConflictResolution可选Variant一个XlSaveConflictResolution值，它确定该方法在保存工作簿时如何解决冲突。如果设为xlUserResolution，则显示冲突解决对话框。如果设为xlLocalSessionChanges，则自动接受本地用户的更改。如果设为xlOtherSessionChanges，则自动接受来自其他会话的更改（而不是本地用户的更改）。如果省略此参数，则显示冲突处理对话框。

AddToMru可选Variant如果为True，则将该工作簿添加到最近使用的文件列表中。默认值为False。

Local可选Variant不在美国英语版的MicrosoftExcel中使用。

TextVisualLayout可选Variant不在美国英语版的MicrosoftExcel中使用。

Local可选Variant如果为True，则以MicrosoftExcel（包括控制面板设置）的语言保存文件。如果为False（默认值），则以VisualBasicforApplications(VBA)（VisualBasicforApplications(VBA)：MicrosoftVisualBasic的宏语言版本，用于编写基于MicrosoftWindows的应用程序，内置于多个Microsoft程序中。）的语言保存文件，其中VisualBasicforApplications(VBA)通常为美国英语版本，除非从中运行Workbooks.Open的VBA项目是旧的已国际化的XL5/95VBA项目。

说明:请使用同时包含大小写字母、数字和符号的强密码。弱密码不混合使用这些元素。强密码：Y6dh!et5。弱密码：House27。请使用您可以记住的强密码，这样就不必将它写下来。

示例:本示例新建一个工作簿，提示用户输入文件名，然后保存该工作簿。

VisualBasicforApplications

SetNewBook=Workbooks.Add

Do

fName=Application.GetSaveAsFilename

LoopUntilfName<>False

NewBook.SaveAsFilename:=fName

1.17禁用宏则关闭Excel文件

=ERROR(FALSE)

=RUN("MY")

=IF(ISERROR($A$3))

=GOTO($A$11)

=END.IF()

=ERROR(TRUE)

=RETURN()

=ALERT("对不起!由于禁用了宏,本文件自动关闭!",3)

=FILE.CLOSE(FALSE)

=RETURN()

禁用宏则关闭Excel文件

'不要删除

FunctionMY()

EndFunction

1.18只能自已电脑上使用的Excel文件

PrivateSubWorkbook_Open()

Application.ScreenUpdating=False

OnErrorGoTo100

Workbooks.OpenThisWorkbook.Path&"/验证.XLS"

ActiveWorkbook.CloseFalse

ExitSub

100:

MsgBox"你无法使用该文件,请与文件作者联系"

ThisWorkbook.CloseFalse

Application.ScreenUpdating=True

EndSub

禁用了宏自动关闭工作薄

FunctionMY()

EndFunction

=ERROR(FALSE)

=RUN("MY")

=IF(ISERROR($A$3))

=GOTO($A$11)

=END.IF()

=ERROR(TRUE)

=RETURN()

=ALERT("对不起!由于禁用了宏,本文件将自动关闭!",3)

=FILE.CLOSE(FALSE)

=RETURN()第2章Excel表格与数据处理2.19判断A1:A7单元格数据类型

Sub判断单元格数据类型()

DimMSTAsString

DimXAsInteger

ForX=1To7

SelectCaseTrue

CaseApplication.IsText(Cells(X,1))

MST="文本"

CaseApplication.IsLogical(Cells(X,1))

MST="逻辑值"

CaseIsEmpty(Cells(X,1))

MST="空值"

CaseIsNumeric(Cells(X,1))

MST="数值"

CaseApplication.IsErr(Cells(X,1))

MST="错误值"

CaseIsDate(Cells(X,1))

MST="日期"

EndSelect

MsgBoxCells(X,1).Address&"的数据类型为:"&MST

NextX

EndSub

2.20单元格区域的端点选取

Sub选取B列第1个非空单元格()

IfRange("b1")=""Then

Range("B1").End(xlDown).Select

Else

Range("b1").Select

EndIf

EndSub

Sub选取B列最后1个非空单元格()

Range("B65536").End(xlUp).Select

EndSu

Sub选取第三5行最左边的值()

IfRange("A11")=""Then

Range("A11").End(xlToRight).Select

Else

Range("A11").Select

EndIf

EndSub

Sub选取第17行最右边非空单元格()

Range("iv17").End(xlToLeft).Select

EndSub

2.21返回单元格区域的合集和交集

Sub单元格合集()

'选取A4:D10区域和B:C列的合并区域

Union(Range("A4:D10"),Columns("B:C")).Select

EndSub

Sub单元格交集()

'选取A4:D10区域和B:C列的交汇区域

Intersect(Range("A4:D10"),Columns("B:C")).Select

EndSub

Application.Union方法：返回两个或多个区域的合并区域。

语法：表达式.Union(Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8,Arg9,Arg10,Arg11,Arg12,Arg13,Arg14,Arg15,Arg16,Arg17,Arg18,Arg19,Arg20,Arg21,Arg22,Arg23,Arg24,Arg25,Arg26,Arg27,Arg28,Arg29,Arg30)

表达式

一个代表Application对象的变量。

参数

名称必选/可选数据类型描述

Arg

必选Range必须指定至少两个Range对象。

返回值：Range

示例：本示例以公式“=RAND()”填充两个命名区域（“Range1”和“Range2”）的合并区域。

VisualBasicforApplications

Worksheets("Sheet1").Activate

SetbigRange=Application.Union(Range("Range1"),Range("Range2"))

bigRange.Formula="=RAND()"

Application.Intersect方法：返回一个Range对象，该对象表示两个或多个区域重叠的矩形区域。

2.22已选取的单元格区域范围和大小

Sub选取区域的总行数()

MsgBox"选取区域的总行数为:"&Selection.Rows.Count_

&Chr(13)+"选取区域的总列数为:"&Selection.Columns.Count

'Chr(13)代表回车

EndSub

Sub选取区域第一行的行数()

MsgBox"选取区域的第一行的行数为:"&Selection.Row

EndSub

Sub选取区域左上角单元格()

MsgBoxSelection.Range("A1").Address

EndSub

Sub选取区域右上角单元格()

MsgBoxCells(Selection.Row,Selection.Column+Selection.Columns.Count-1).Address

EndSub

Sub选取区域左下角单元格()

MsgBoxCells(Selection.Row+Selection.Rows.Count-1,Selection.Column).Address

EndSub

Sub选取区域右下角单元格()

MsgBoxSelection.Cells(Selection.Cells.Count).Address

EndSub

2.23高亮显示当前行和列

PrivateSubWorkbook_SheetSelectionChange(ByValShAsObject,ByValTargetAsRange)

Application.ScreenUpdating=False

Cells.Interior.ColorIndex=-4142

Rows(Target.Row).Interior.ColorIndex=20

Columns(Target.Column).Interior.ColorIndex=20

Application.ScreenUpdating=True

EndSub

2.24检查单元格中是否含有公式

Sub判断单元格中是否含有公式()

ForI=4To10

IfCells(I,3).HasFormulaThen

K=K+1

EndIf

NextI

MsgBox"该区域中共有"&K&"个单元格含有公式"

EndSub

Range.HasFormula属性：如果区域中所有单元格均包含公式，则该属性值为True；如果所有单元格均不包含公式，则该属性值为False；其他情况下为null。Variant类型，只读。

语法：表达式.HasFormula

表达式

一个代表Range对象的变量。

2.25判断单元格是否处于隐藏状态

Sub判断单元格的隐藏状态()

ForX=1To10

IfCells(X,1).EntireRow.HiddenOrCells(X,1).EntireColumn.HiddenThen

MYH=MYH&Cells(X,1).Address&"、"

EndIf

NextX

MYH=Left(MYH,Len(MYH)-1)

MsgBox"单元格"&MYH&"处于隐藏状态"

EndSub

2.26批量删除空行

Sub删除空行()

Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

EndSub

Range.SpecialCells方法

返回一个Range对象，该对象代表与指定类型和值匹配的所有单元格。

语法：表达式.SpecialCells(Type,Value)

表达式

一个代表Range对象的变量。

参数：名称必选/可选数据类型描述

Type必选XlCellType要包含的单元格。

Value可选Variant如果Type为xlCellTypeConstants或xlCellTypeFormulas，则该参数可用于确定结果中应包含哪几类单元格。将这些值相加可使此方法返回多种类型的单元格。默认情况下，将选择所有常量或公式，无论类型如何。

返回值：Range

说明

XlCellType常量值

xlCellTypeAllFormatConditions：任意格式单元格-4172

xlCellTypeAllValidation：含有验证条件的单元格-4174

xlCellTypeBlanks：空单元格4

xlCellTypeComments：含有注释的单元格-4144

xlCellTypeConstants：含有常量的单元格2

xlCellTypeFormulas：含有公式的单元格-4123

xlCellTypeLastCell：已用区域中的最后一个单元格11

xlCellTypeSameFormatConditions：含有相同格式的单元格-4173

xlCellTypeSameValidation：含有相同验证条件的单元格-4175

xlCellTypeVisible：所有可见单元格12

XlSpecialCellsValue常量值

xlErrors16

xlLogical4

xlNumbers

1

xlTextValues2

示例：本示例选定工作表Sheet1中已用区域的最后一个单元格。

VisualBasicforApplications

Worksheets("Sheet1").Activate

ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate

2.27控制重复录入

PrivateSubWorksheet_Change(ByValTargetAsRange)

IfTarget.Column=1Then

"

IfTarget.Value<>""""AndApplication._

CountIf(Columns(1),Target.Value)>1Then"

MsgBox"请不要重复录入"

Application.Undo

EndIf

EndIf

EndSub

删除SHEET2重复SHEET1的记录

Sub删除SHEET2重复SHEET1()

I=Sheets("SHEET1").Range("B65536").End(xlUp).Row

N=Sheets("SHEET2").Range("B65536").End(xlUp).Row

ForEachRNGInSheets("SHEET1").Range("B1:B"&I)

ForX=1ToN

IfRNG.Value=Sheets("SHEET2").Range("B"&X).ValueThen

Sheets("SHEET2").Range("B"&X).EntireRow.Delete

EndIf

NextX

NextRNG

EndSub

Range.EntireRow属性

返回一个Range对象，该对象表示包含指定区域的整行（或多行）。只读。

语法：表达式.EntireRow

表达式

一个代表Range对象的变量

2.28自动填充公式

PrivateSubWorksheet_Change(ByValTargetAsRange)

DimX

X=Target.Row

IfCells(X,2)<>""AndCells(X,3)<>""Then

Cells(X,4).Formula="=B"&X&"*C"&X

EndIf

EndSub

Range.Formula属性：返回或设置一个Variant值，它代表A1样式表示法和宏语言中的对象的公式。

语法：表达式.Formula

表达式

一个代表Range对象的变量。

说明：此属性对于OLAP（OLAP：为查询和报表（而不是处理事务）而进行了优化的数据库技术。OLAP数据是按分级结构组织的，它存储在多维数据集而不是表中。）数据源无效。

如果单元格包含一个常量，此属性返回该常量。如果单元格为空，此属性返回一个空字符串。如果单元格包含公式，Formula属性将该公式作为字符串返回，所用格式与在编辑栏（包括等号）中显示时的格式相同。

如果将单元格的值或者公式设置为日期类型，则MicrosoftExcel将检查此单元格的数字格式是否符合日期或者时间格式。如果不符合，MicrosoftExcel将把数字格式设置为默认的短日期格式。

如果指定区域是一维或二维区域，则可将公式指定为VisualBasic中相同维数的数组。同样，也可在VisualBasic数组中使用公式。

如果为多单元格区域设置公式，则会用公式填充该区域所有的单元格。

示例：此示例设置Sheet1中A1单元格的公式。

VisualBasicforApplications

Worksheets("Sheet1").Range("A1").Formula="=$A$4+$A$10"

2.29每隔5行插入一个空行

Sub插入空行()

DimxxAsInteger

xx=Int([A65536].End(xlUp).Row/5)

ForI=1Toxx

Rows(I*5+1+K).Insert

K=K+1

NextI

EndSub

Sub删除空行()

Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

EndSub

2.30产生不重复随机整数

Sub产生不重复随机数()

DimMRAsRange

ForEachMRInRange("A1:A10")

Do

MR=Int(Rnd()*100+1)

LoopUntilApplication.CountIf(Range("A1:A10"),MR)=1

NextMR

EndSub

随机制作布产单(见其他文件夹)

Sub布产()

DimjAsLong

DimrngAsRange

Dimrng1AsRange

DimlastAsInteger

Setrng=Range("iv1").End(xlToLeft)

j=Int((5/(rng.Column-2))*100)'设置5个的随机率

Forx=2ToRange("a65536").End(xlUp).Row-1'行循环

100:

'纠错循环

Range(Cells(x,3),Cells(x,rng.Column))=Empty

'清空当前行

Fori=3Torng.Column'列循环

upval=Int((Cells(x,2)/5)*1.3)'设置130%上限

downval=Int((Cells(x,2)/5)*0.7)'设置70%下限

y=Int(Rnd*100)'设置随机率

Ify<jThen'判断随机率

Cells(x,i)=Int(Rnd*(upval-downval+1)+downval)'赋值

EndIf

Nexti

Setrng1=Range("iv"&x).End(xlToLeft)'取最后的单元格

last=rng1.Column-1

'重新为最后的单元格赋值

rng1.Value=Cells(x,2).Value-Application.Sum(Range(Cells(x,3),Cells(x,last)))

Ifrng1>upvalOrrng1<downvalThenGoTo100'避免差异过大

Nextx

MsgBox"完成任务"

EndSub

2.31重复内容的指定位置查找

Sub重复记录的查找()

DimXAsInteger

X=Application.CountIf(Columns("B"),"A")

SetMRG=Columns(2).Find("A",[B65536])

MsgBox"共有"&X&"个A，第1个A的地址为:"&MRG.Address

ForY=1ToX-1

SetMRG=Columns(2).Find("A",MRG)

MsgBox"共有"&X&"个A，第"&Y+1&"个A的地址为:"&MRG.Address

NextY

EndSub

Range.Find方法：在区域中查找特定信息。

语法：表达式.Find(What,After,LookIn,LookAt,SearchOrder,SearchDirection,MatchCase,MatchByte,SearchFormat)

表达式

一个代表Range对象的变量。

参数：

名称必选/可选数据类型描述

What必选Variant要搜索的数据。可为字符串或任意MicrosoftExcel数据类型。

After可选Variant表示搜索过程将从其之后开始进行的单元格。此单元格对应于从用户界面搜索时的活动单元格的位置。请注意：After必须是区域中的单个单元格。要记住搜索是从该单元格之后开始的；直到此方法绕回到此单元格时，才对其进行搜索。如果不指定该参数，搜索将从区域的左上角的单元格之后开始。

LookIn可选Variant信息类型。

LookAt可选Variant可为以下XlLookAt常量之一：xlWhole或xlPart。

SearchOrder可选Variant可为以下XlSearchOrder常量之一：xlByRows或xlByColumns。

SearchDirection可选XlSearchDirection搜索的方向。

MatchCase可选Variant如果为True，则搜索区分大小写。默认值为False。

MatchByte可选Variant只在已经选择或安装了双字节语言支持时适用。如果为True，则双字节字符只与双字节字符匹配。如果为False，则双字节字符可与其对等的单字节字符匹配。

SearchFormat可选Variant搜索的格式。

返回值：一个Range对象，它代表第一个在其中找到该信息的单元格。

说明：

如果未发现匹配项，则返回Nothing。Find方法不影响选定区域或当前活动的单元格。

每次使用此方法后，参数LookIn、LookAt、SearchOrder和MatchByte的设置都将被保存。如果下次调用此方法时不指定这些参数的值，就使用保存的值。设置这些参数将更改“查找”对话框中的设置，如果省略这些参数，更改“查找”对话框中的设置将更改使用的保存值。要避免出现这一问题，每次使用此方法时请明确设置这些参数。

使用FindNext和FindPrevious方法可重复搜索。

当搜索到指定查找区域的末尾时，此方法将绕回到区域的开始位置继续搜索。发生绕回后，要停止搜索，可保存第一个找到的单元格地址，然后测试后面找到的每个单元格地址是否与其相同。

若要对单元格进行模式更为复杂的搜索，请结合使用ForEach...Next语句和Like运算符。例如，下列代码在单元格区域A1:C5中搜索字体名称以“Cour”开始的单元格。当MicrosoftExcel找到匹配单元格以后，就将其字体改为TimesNewRoman。

ForEachcIn[A1:C5]Ifc.Font.NameLike"Cour*"Thenc.Font.Name="TimesNewRoman"EndIfNext

示例：本示例在第一个工作表的单元格区域A1:A500中查找包含值2的所有单元格，并将这些单元格的值更改为5。

VisualBasicforApplications

WithWorksheets(1).Range("a1:a500")

Setc=.Find(2,lookin:=xlValues)

IfNotcIsNothingThen

firstAddress=c.Address

Do

c.Value=5

Setc=.FindNext(c)

LoopWhileNotcIsNothingAndc.Address<>firstAddress

EndIf

EndWith

2.32相同内容单元格的批量合并与拆分

Sub合并单元格()

Application.DisplayAlerts=False

OnErrorResumeNext

WithSelection

ForI=.CountTo1Step-1

If.Cells(I)=.Cells(I-1)And.Cells(I)<>""Then

Range(.Cells(I),.Cells(I-1)).Merge

EndIf

NextI

EndWith

EndSub

Sub单元格拆分()

DimMRAsRange

Selection.UnMerge

ForEachMRInSelection

IfMR=""Then

MR=MR.Offset(-1,0).Value

EndIf

Next

EndSub

Range.Merge方法：由指定的Range对象创建合并单元格。

语法：表达式.Merge(Across)

表达式

一个代表Range对象的变量。

参数：名称必选/可选数据类型描述

Across可选Variant如果为True，则将指定区域中每一行的单元格合并为一个单独的合并单元格。默认值是False。

说明：合并区域的值在该区域左上角的单元格中指定2.33唯一值的提取

Sub唯一值提取()

DimXAsInteger

X=[A65536].End(xlUp).Row

Range("A1:A"&X).AdvancedFilterAction:=xlFilterCopy,CopyToRange:=Range(_

"B1"),Unique:=True

EndSub

Range.AdvancedFilter方法

基于条件区域从列表中筛选或复制数据。如果初始选定区域为单个单元格，则使用单元格的当前区域。

语法：表达式.AdvancedFilter(Action,CriteriaRange,CopyToRange,Unique)

表达式

一个代表Range对象的变量。

参数：

名称必选/可选数据类型描述

Action必选XlFilterActionXlFilterAction的常量之一，用于指定是否就地复制或筛选列表。

CriteriaRange可选Variant条件区域。如果省略该参数，则没有条件限制。

CopyToRange可选Variant如果Action为xlFilterCopy，则为复制行的目标区域。否则，忽略该参数。

Unique可选Variant如果为True，则只筛选唯一记录。如果为False，则筛选符合条件的所有记录。默认值为False。

返回值：Variant

示例：本示例基于条件区域“Criteria”筛选数据库“Database”。

VisualBasicforApplications

Range("Database").AdvancedFilter_

Action:=xlFilterInPlace,_

CriteriaRange:=Range("Criteria")

。

2.34查找合并单元格地址

Sub查找合并单元格位置()

DimMRGAsRange

ForEachMRGInActiveSheet.UsedRange

IfMRG.MergeArea.Address<>MRG.AddressAndMRG.MergeArea.Address<>KThen

K=MRG.MergeArea.Address

MsgBoxK

EndIf

NextMRG

EndSub

Range.MergeArea属性：返回一个Range对象，该对象代表包含指定单元格的合并区域。如果指定的单元格不在合并区域内，则该属性返回指定的单元格。只读。Variant类型。

语法：表达式.MergeArea

表达式

一个代表Range对象的变量。

说明：MergeArea属性只应用于单个单元格区域。

示例：本示例为包含单元格A3的合并区域赋值。

VisualBasicforApplications

Setma=Range("a3").MergeArea

Ifma.Address="$A$3"Then

MsgBox"notmerged"

Else

ma.Cells(1,1).Value="42"

EndIf

2.35查找合并单元格地址

PrivateSubWorkbook_NewSheet(ByValShAsObject)

MsgBox"你不能插入工作表"

Application.DisplayAlert