适用代码实例解析.docx

1、适用代码实例解析第一部 VBA技巧应用(作者：赵志东)第1章 Excel文件与文件夹操作1.1返回当前Excel文件的路径Sub 打开文件B()Dim MST As String 声明变量MST = ThisWorkbook.Path 把当前文件的路径赋予MSTWorkbooks.Open MST & B.XLS 打开文件BEnd SubWorkbooks.Open 路径+名称,打开指定工作薄1.2返回指定文件夹中的文件列表Sub 列出所有文件名()Dim xlsFile As String DIR(路径):此路径下的E文件名集合中的一成员xlsFile = Dir(ActiveWorkboo

2、k.Path & *.XLS) Do如文件名不含有汇总,则If InStr(1, xlsFile, 汇总) = 0 Then Cells(A65536.End(xlUp).Row + 1), 1) = xlsFileEnd IfxlsFile = Dir如果UNTIL条件成立,则跳出DO循环Loop Until Len(xlsFile) = 0End SubDir(pathname, attributes)，在第一次调用 Dir 函数时，必须指定 pathname，否则会产生错误。如果也指定了文件属性，那么就必须包括 pathname。Dir 会返回匹配 pathname 的第一个文件名。若想

3、得到其它匹配 pathname 的文件名，再一次调用 Dir，且不要使用参数。如果已没有合乎条件的文件，则 Dir 会返回一个零长度字符串 ()。一旦返回值为零长度字符串，并要再次调用 Dir 时，就必须指定 pathname，否则会产生错误。不必访问到所有匹配当前 pathname 的文件名，就可以改变到一个新的 pathname 上。但是，不能以递归方式来调用 Dir 函数。以 vbDirectory 属性来调用 Dir 不能连续地返回子目录。1.3判断文件夹中指定文件是否存在Sub 判断AAA文件是否存在()Set FS = Application.FileSearch设FS为文件名称

4、With FS .LookIn = ThisWorkbook.Path 确定路径 .Filename = AAA.XLS 查找的文件名 If .Execute() 0 Then 判断查找的结果 MsgBox AAA文件存在 Else MsgBox AAA文件不存在 End IfEnd WithEnd SubFileSearch 属性：为文件搜索返回一个 FileSearch 对象。LookIn 属性：返回或设置在指定的文件搜索过程中要搜索的文件夹FileName 属性：返回或设置保存指定源对象位置的 URL（Intranet 或网站上）或路径（本地或网络）。String 类型，可读写。Exec

5、ute 方法：激活与单元格中智能标记类型相关的智能标记操作。语法：expression.Execute，expression 必需。该表达式返回“应用于”列表中的对象之一。提取指定文件夹的EXCEL文件名称Sub 提取EXCEL文件名称()Application.ScreenUpdating = False停止刷新MC = ActiveWorkbook.NameDim ss As WorkbookWith Application.FileSearch.LookIn = Application.ThisWorkbook.Path + 文件.Filename = *.xls If .Execute

6、() 0 Then MsgBox 共有 & .FoundFiles.Count & 个需要读取的文件 。, , 读取EXCEL文件名 For i = 1 To .FoundFiles.Count Set ss = 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

7、) = bs Workbooks(ss.Name).Close SaveChanges:=False Next i Else MsgBox 文件 文件夹中没有需要读取的文件 。, , 读取EXCEL文件名 End IfEnd WithApplication.ScreenUpdating = TrueEnd SubFoundFiles 属性: 返回一个 FoundFiles 对象，该对象包括一次查找操作中找到的所有文件的文件名。只读。FoundFiles 对象参阅属性方法事件特性代表由文件查找过程返回的文件列表。使用 FoundFiles 对象用 FoundFiles 属性可返回 FoundFi

8、les 对象。本示例可实现：逐个查看找到的文件列表中的文件并显示其中每个文件的文件名和路径。用 FoundFiles(index) 可返回查找过程中指定文件的名称和位置，此处的 index 是该文件的索引号。1.4在文件夹之间复制和移动Excel文件Sub 复制表1()FileCopy ThisWorkbook.Path & /表1.XLS, ThisWorkbook.Path & /目标/表1.XLSEnd SubSub 移动表2()FileCopy ThisWorkbook.Path & /表2.XLS, ThisWorkbook.Path & /目标/表2.XLSKill ThisWor

9、kbook.Path & /表2.XLSEnd Sub注释：FileCopy 语句 :复制一个文件。语法:FileCopy source, destinationFileCopy 语句的语法含有以下这些命名参数的描述 source 必要参数。字符串表达式，用来表示要被复制的文件名。source 可以包含目录或文件夹、以及驱动器。 destination 必要参数。字符串表达式，用来指定要复制的目地文件名。destination 可以包含目录或文件夹、以及驱动器。 说明:如果想要对一个已打开的文件使用 FileCopy 语句，则会产生错误。注释：Kill 语句 :从磁盘中删除文件。语法:Kill

10、 pathname必要的 pathname 参数是用来指定一个文件名的字符串表达式。pathname 可以包含目录或文件夹、以及驱动器。说明:在 Microsoft Windows 中，Kill 支持多字符 (*) 和单字符 (?) 的统配符来指定多重文件。. 如果使用 Kill 来删除一个已打开的文件，则会产生错误。注意 若要删除目录，使用 RmDir 语句1.5判断指定文件夹是否存在Sub 判断文件夹是否存在()Set YYY = CreateObject(Scripting.FileSystemObject)设YYY为文件夹对象变量If YYY.FolderExists(ThisWork

11、book.Path & A) = True ThenMsgBox A文件夹存在ElseMsgBox A文件夹不存在MkDir ThisWorkbook.Path & AEnd IfSet YYY = NothingEnd Sub注释：FileExists(路径+文件名)： 检验文件是否存在，返回true,false注释：MkDir 语句 :创建一个新的目录或文件夹。语法:MkDir path必要的 path 参数是用来指定所要创建的目录或文件夹的字符串表达式。path 可以包含驱动器。如果没有指定驱动器，则 MkDir 会在当前驱动器上创建新的目录或文件夹。Scripting.FileSyst

12、emObject需添加引用的“MIscosoft scripting runtime”，1.6列示所有子文件夹名称Sub ShowFolderList()运行cmd命令注消FSO组件：RegSvr32 /u %windir%SYSTEM32scrrun.dll启用FSO命令：RegSvr32 %windir%SYSTEM32scrrun.dll Dim fs, f, f1, fc, s Set fs = CreateObject(Scripting.FileSystemObject)创建FileSystemObject对象 Set f = fs.GetFolder(ThisWorkbook.P

13、ath)创建文件夹对象 Set fc = f.SubFolders 取得文件夹集合 For Each f1 In fc s = s & f1.Name s = s & vbCrLf 在每个文件夹名后加回车和换行符 Next MsgBox sEnd Sub注释：GetFolder(路径) 取得目录对象注释：SubFolders 属性 :返回一个 Folders 集合，由指定文件夹中包含的所有文件夹组成，包括设置了隐藏和系统文件属性的文件夹。object.SubFolders object 应为 Folder 对象 1.7文件夹的复制和移动Sub 复制A文件夹到C() Dim f, fsSet f

14、s = CreateObject(Scripting.FileSystemObject)Set f = fs.GetFolder(ThisWorkbook.Path & A) 得到folder对象 f.Copy (ThisWorkbook.Path & C) 复制文件夹 MsgBox 复制成功!End SubSub 移动B文件夹到C() Dim f, fsSet fs = CreateObject(Scripting.FileSystemObject)Set f = fs.GetFolder(ThisWorkbook.Path & B) 得到folder对象 f.Move (ThisWorkb

15、ook.Path & C) 移动文件夹 MsgBox 移动成功!End Sub注释：Move 方法:将指定工作表移到工作簿的另一位置。语法:expression.Move(Before, After)expression 必需。该表达式返回“应用于”列表中的对象之一。Before Variant 类型，可选。表示某工作表，欲移动的工作表将移到此工作表之前。如果已经指定了 After，则不能指定 Before。After Variant 类型，可选。表示某工作表，欲移动的工作表将移到此工作表之后。如果已经指定了 Before，则不能指定 After。说明：如果既不指定 Before 参数也不指定

16、 After 参数，则 Microsoft Excel 将新建一个工作簿并将欲移动的工作表移到新工作簿中。示例：本示例将 Sheet1 移到当前活动工作簿的 Sheet3 之后。Worksheets(Sheet1).Move _ after:=Worksheets(Sheet3)1.8批量删除文件夹 Sub 批量删除文件夹() Dim fs, f, f1, fc Set fs = CreateObject(Scripting.FileSystemObject)创建FileSystemObject对象 Set f = fs.GetFolder(ThisWorkbook.Path)创建指定路径文件

17、夹对象 Set fc = f.SubFolders 取得文件夹集合 For Each f1 In fc If InStr(1, f1.Name, A) 0 Then判断文件夹名称中是否包含字符A f1.Delete 删除文件夹 MsgBox 删除成功 End If Next f1End Sub注释：InStr 函数：返回 Variant (Long)，指定一字符串在另一字符串中最先出现的位置。语法 ：InStr(start, string1, string2, compare)InStr 函数的语法具有下面的参数：部分 说明 start 可选参数。为数值表达式，设置每次搜索的起点。如果省略，将

18、从第一个字符的位置开始。如果 start 包含 Null，将发生错误。如果指定了 compare 参数，则一定要有 start 参数。 string1 必要参数。接受搜索的字符串表达式。 string2 必要参数。被搜索的字符串表达式。 Compare 可选参数。指定字符串比较。如果 compare 是 Null，将发生错误。如果省略 compare，Option Compare 的设置将决定比较的类型。指定一个有效的LCID (LocaleID) 以在比较中使用与区域有关的规则。 compare 参数设置为：常数 值 描述 vbUseCompareOption -1 使用Option Com

19、pare 语句设置执行一个比较。 vbBinaryCompare 0 执行一个二进制比较。 vbTextCompare 1 执行一个按照原文的比较。 vbDatabaseCompare 2 仅适用于Microsoft Access，执行一个基于数据库中信息的比较。 返回值：如果 InStr返回 ；string1 为零长度 0 ；string1 为 Null Null string2 为零长度 Start；string2 为 Null Null string2 找不到 0 ；在 string1 中找到string2找到的位置 ；start string2 0 说明InStrB 函数作用于包含在字

20、符串中的字节数据。所以 InStrB 返回的是字节位置，而不是字符位置。1.9获取文件夹大小Sub 获取文件夹信息()Set fs = CreateObject(Scripting.FileSystemObject)Set f = fs.GetFolder(ThisWorkbook.Path & A)创建文件夹对象S = f.Name & 文件夹的大小为 & FormatNumber(f.Size / 1024, 0) & KB & vbCrLf 得到文件夹大小,vbCrLf 是换行符MsgBox SEnd Sub注释：FormatNumber函数：返回一个数字格式的表达式。语法：Format

21、Number(Expression,NumDigitsAfterDecimal ,IncludeLeadingDigit ,UseParensForNegativeNumbers ,GroupDigits)FormatNumber函数语法有如下几部分：部分 描述 Expression 必需的。要被格式化的表达式。 NumDigitsAfterDecimal 可选的。数字值，表示小数点右边的显示位数。缺省值为1，表示使用计算机的区域设置值。 IncludeLeadingDigit 可选的。三态常数，表示小数点前是否显示零。关于其值，请参阅“设置值”部分。 UseParensForNegative

22、Numbers 可选的。三态常数，表示是否把负数值放在圆括号内。关于其值，请参阅“设置值”部分。 GroupDigits 可选的。的三态常数，表示是否用组分隔符对数字分组，组分隔符在计算机的区域设置值中指定。关于其值，请参阅“设置值”部分。 设置值IncludeLeadingDigit、UseParensForNegativeNumbers和GroupDigits参数的设置值如下：常数 值 描述 vbTrue 1 True vbFalse 0 False vbUseDefault 2 用计算机区域设置值中的设置值。 说明：当忽略一个或多个选项参数时，被忽略的参数值由计算机的区域设置值提供。注意

23、 所有设置值信息都来自“区域设置”的“数字”选项卡。1-19用U盘系列号做工作薄打开密码Private Sub Workbook_Open()Call U盘锁代码End SubSub U盘锁代码()Dim fs, d, s$On Error Resume NextFor i = 3 To 26 26个字母Set fs = CreateObject(scripting.filesystemobjEct)Set d = fs.getdrive(Chr(64 + i) & :)s = d.SERIALNUMBER 取得驱动器的系列号Select Case sCase 134374432 U盘系列号M

24、sgBox 成功打开Exit SubEnd SelectSet fs = NothingSet d = NothingNextThisWorkbook.Close FalseEnd Sub注释1：注释2：Workbook.Close 方法 ：关闭对象。语法：表达式.Close(SaveChanges, Filename, RouteWorkbook)表达式 一个代表 Workbook 对象的变量。参数名称 必选/可选 数据类型 描述 SaveChanges 可选 Variant 如果工作簿中没有改动，则忽略此参数。如果工作簿中有改动但工作簿显示在其他打开的窗口中，则忽略此参数。如果工作簿中有改

25、动且工作簿未显示在任何其他打开的窗口中，则由此参数指定是否应保存更改。如果设为 True，则保存对工作簿所做的更改。如果工作簿尚未命名，则使用 FileName。如果省略 Filename，则要求用户提供文件名。 Filename 可选 Variant 以此文件名保存所做的更改。 RouteWorkbook 可选 Variant 如果工作簿不需要传送给下一个收件人（没有传送名单或已经传送），则忽略此参数。否则，Microsoft Excel 根据此参数的值传送工作簿。如果设为 True，则将工作簿传送给下一个收件人。如果设为 False，则不发送工作簿。如果忽略，则要求用户确认是否发送工作簿。

26、 说明：从 Visual Basic 关闭工作簿并不运行该工作簿中的任何 Auto_Close 宏。使用 RunAutoMacros 方法可运行自动关闭宏。示例：此示例关闭 Book1.xls，并放弃所有对此工作簿的更改。Visual Basic for Applications Workbooks(BOOK1.XLS).Close SaveChanges:=False获取所有磁盘序列Sub 获取所有磁盘序列号() Dim fs, d, aa As String, b As String, c As String Set fs = CreateObject(Scripting.FileSyst

27、emObject) On Error Resume Next For i = 1 To 26bb: aa = ABCDEFGHIJKLMNOPQRSTUVWXYZ b = Mid(aa, i, 1) Set d = fs.getdrive(fs.GetDriveName(fs.GetAbsolutePathName(b & :) If Err.Number = 68 Then s = b & :盘未准备好 Err.Clear GoTo aa End If Select Case d.DriveType Case 0: t = Unknown Case 1: t = Removable Case

28、 2: t = Fixed Case 3: t = Network Case 4: t = CD-ROM Case 5: t = RAM Disk End Select s = 磁盘: & d.DriveLetter & 类型: & t & 序列号: & d.SERIALNUMBERaa: c = c & s & Chr(10) Next i MsgBox c, 64, andysky提示你End Sub改进型U盘锁保护Sub U盘锁()Dim fs, s$On Error Resume NextSet fs = CreateObject(scripting.filesystemobjEct)For Each DRI In fs.DRIVESs = DRI.SERIALNUMBERIf s = 134374432 Then U盘系列号MsgBox 打开成功Set fs = NothingExit SubEnd IfNextSet fs = NothingMsgBox 打开失败ThisWorkbook.Clos