适用代码实例解析.docx
《适用代码实例解析.docx》由会员分享，可在线阅读，更多相关《适用代码实例解析.docx（75页珍藏版）》请在冰豆网上搜索。
适用代码实例解析
第一部《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.Clos
升级会员 