VBA资料及文夹操作

《VBA资料及文夹操作》由会员分享，可在线阅读，更多相关《VBA资料及文夹操作（33页珍藏版）》请在装配图网上搜索。

1、VBA 文件及文件夹操作1.VBA 操作文件及文件夹on error resume next下测试A，在 D： 下新建文件夹，命名为folder方法 1：MkDir D ：folder方法 2：Set abc = CreateObject(Scripting.FileSystemObject)abc.CreateFolder (D：folder)B，新建 2 个文件命名为 a.xls 和 b.xlsWorkbooks.AddActiveWorkbook.SaveAs Filename：=D ： foldera.xlsActiveWorkbook.SaveAs Filename：=D ： fol

2、derb.xlsC,创建新文件夹 folder1 并把 a.xls 复制到新文件夹重新命名为c.xlsMkDir D ：folder1FileCopy D ：foldera.xls, D ：folder1c.xlsD,复制 folder 中所有文件到 folder1Set qqq = CreateObject(Scripting.FileSystemObject)qqq.CopyFolder D：folder, D ：folder1D,重命名 a.xls 为 d.xlsname d：folder1a.xls as d：folder1d.xlsE,判断文件及文件夹是否存在Set yyy = Cr

3、eateObject(Scripting.FileSystemObject)If yyy.FolderExists(D ：folder1) = True Then .If yyy.FileExists(D ：folder1d.xls) = True Then .1/33F,打开 folder1 中所有文件Set rrr = CreateObject(Scripting.FileSystemObject)Set r = rrr.GetFolder(d：folder1)For Each i In r.FilesWorkbooks.Open Filename：=(d：folder1 + i.Name

4、 + )NextG,删除文件 c.xlskill d ：folder1c.xlsH,删除文件夹 folderSet aaa = CreateObject(Scripting.FileSystemObject)aaa.DeleteFolder d：folder2. excel vba 一次性获取文件夹下的所有文件名的方法小生今天上网下载了一个财务常用报表的文件包，里面有几百个 excel 工作表，要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。于是想到昨论坛就是 vba 论坛，昨不充分利用 excel 自身的高级应用呀， 呵呵，实现的代码如下，把工作量几天的任务可是一下子就完成了，这就

5、是 excel vba给你工作提高效率的结果！excle vba 自动获取同一文件夹下所有工作表的名称红色代码：按 Alt+F11 ，打开 VBA 编辑器，插入一个模块，把下面的代码贴进去，按F5执行Sub t()Dim s As FileSearch 定义一个文件搜索对象Set s = Application.FileSearchs.LookIn = c ： 注意路径，换成你实际的路径2/33s.Filename = *.* 搜索所有文件s.Execute 执行搜索Cells.Delete 表格清空Cells(i, 1) = s.FoundFiles(i) 每一行第一列填写一个文件名Next

6、End Sub现在获得的可是带路径的工作表名，去掉前的路径可用以下方法；=RIGHT(A1,LEN(A1)-FIND(#,SUBSTITUTE(A1,#,LEN(A1)-LEN(SUBSTITUTE(A1,)最后用常规的方法往下拖，就完成了笔者所需的工作表名。outlook 下 VBA 编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上2009-06-17 09：35Sub SaveAttachments()Dim oApp As Outlook.ApplicationDim oNameSpace As NameSpaceDim oFolder As MAPIFolderDim oMailIt

7、em As ObjectDim sMessage As StringBeforeDate = #10/1/2007# choose the end date of wantedMyDir = E ：liuxc-workoil lossbackup from public folder choose thefolder location for saveSender = Hz121 Supervisor caution, case sensitive3/33SendFile = HZ121-1_Daily.xlsMyY = 0Set oApp = New Outlook.ApplicationS

8、et oNameSpace = oApp.GetNamespace(MAPI)Set oFolder = oNameSpace.PickFolderFor Each oMailItem In oFolder.ItemsWith oMailItemMyT3 = Left(CStr(oMailItem.CreationTime), 10)If CDate(oMailItem.CreationTime) = BeforeDate Then If oMailItem.SenderName = Sender ThenEnd IfNext iEnd IfEnd IfElse4/33MyY = MyY +

9、1If MyY 10 Then GoTo LoopEndEnd IfEnd WithNext oMailItemLoopEnd： Set oMailItem = Nothing Set oFolder = Nothing Set oNameSpace = Nothing Set oApp = Nothing3.Excel VBA 把选定文件夹中的工作簿导入到新建 ACCESS 数据库中2010-04-24 22：33方法一Sub Create_AccessProject()Dim AccessData As ObjectSet AccessData = CreateObject(Access.

10、Application)Dim Stpath As StringStpath = ThisWorkbook.Path & DSEM-Stock-Allocation.mdb 设定路径 If Dir(Stpath, vbDirectory) = DSEM-Stock-Allocation.mdb Then Kill (Stpath)End IfAccessData.NewCurrentDatabase StpathSet AccessData = Nothing 创建表格5/33Application.Wait Now() + TimeValue(00 ：00：02) 系统暂停 2 秒,以等待d

11、ata.mdb建立成功cnnaccess.Open Data Source = & Stpath & 。Jet OLEDB ：Database Password= & strSQL = Create Table myData(last_date char(8)rstAnswers.Open strSQL, cnnaccessSet rstAnswers = NothingSet cnnaccess = NothingMyMainFile = ThisWorkbook.NameDim CurFile As StringApplication.DisplayAlerts = FalsemyFile

12、 = Application.GetOpenFilename(*.xls),*.xls), , Please Select Files)If myFile = False Then Exit SubDirLoc = CurDir(myFile) & CurFile = Dir(DirLoc & *.xls)Do While CurFile vbNullStringSet objAccess = CreateObject(Access.Application)LinkFile = DirLoc & CurFileTableName = Left(CurFile, Len(CurFile) - 4

13、)If CurFile = HONHAI-VMIData1.xls Then6/33With objAccess.OpenCurrentDatabase (ThisWorkbook.Path & DSEM-Stock-Allocation.mdb).DoCmd.TransferSpreadsheet acLink, 8, TableName, LinkFile, True, Aging Report$End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingCurFile = DirElseWith objAccess.OpenC

14、urrentDatabase (ThisWorkbook.Path & DSEM-Stock-Allocation.mdb).DoCmd.TransferSpreadsheet acImport, 8, TableName, LinkFile, True, End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingCurFile = DirEnd IfLoopEnd Sub方法二Sub Folder2Access()Dim db As DAO.Database7/33Dim ws As DAO.WorkspaceSet ws =

15、DBEngine.Workspaces(0)Setdb=ws.OpenDatabase(C：CustomersDataBaseDSEM-PO-Stock-Status.mdb, False, False, )db.Execute (delete * from DSEM-MovingPlan)db.CloseSet db = NothingDim myFile As StringDim s As FileSearch 定义一个文件搜索对象 Set s = Application.FileSearchs.LookIn = C ：CustomersDataBaseTest注意路径，换成你实际的路径s

16、.Filename = *.* 搜索所有文件s.Execute 执行搜索FullName1=Right(s.FoundFiles(i),Len(s.FoundFiles(i)-Len(C ：CustomersDataBaseTest)Filename = Left(FullName1, Len(FullName1) - 4)Set objAccess = CreateObject(Access.Application)myFile = C ：CustomersDataBaseTest & Filename & .xlsWith objAccess.OpenCurrentDatabase(C：C

17、ustomersDataBaseDSEM-PO-Stock-Status.mdb).DoCmd.TransferSpreadsheet acImport, 8, DSEM-MovingPlan, myFile, True, 8/33End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingNextEnd Sub4. vba 操作文件及文件夹示例2009-08-20 00：07vba 操作文件及文件夹示例利用 excel 中的 vba 可以对电脑中的文件及文件夹做一些常用的操作。包括复制、重命名、删除等，其中一些简单的示例总结如下。

18、希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！以下代码建议在on error resume next下测试1，在 D： 下新建文件夹，命名为folder方法 1：MkDir D ：folder方法 2：Set abc = CreateObject(Scripting.FileSystemObject)abc.CreateFolder (D：folder)2，新建 2 个文件命名为 a.xls 和 b.xlsWorkbooks.AddActiveWorkbook.SaveAs Filename：=D ： foldera.xlsActiveWorkbook.SaveAs

19、 Filename：=D ： folderb.xls3,创建新文件夹 folder1 并把 a.xls 复制到新文件夹重新命名为c.xlsMkDir D ：folder1FileCopy D ：foldera.xls, D ：folder1c.xls4,复制 folder 中所有文件到 folder19/33Set qqq = CreateObject(Scripting.FileSystemObject)qqq.CopyFolder D：folder, D ：folder15,重命名 a.xls 为 d.xlsname d：folder1a.xls as d：folder1d.xls6,判断

20、文件及文件夹是否存在Set yyy = CreateObject(Scripting.FileSystemObject)If yyy.FolderExists(D ：folder1) = True Then .If yyy.FileExists(D ：folder1d.xls) = True Then .7,打开 folder1 中所有文件Set rrr = CreateObject(Scripting.FileSystemObject)Set r = rrr.GetFolder(d：folder1)For Each i In r.FilesWorkbooks.Open Filename：=(

21、d：folder1 + i.Name + )Next 8,删除文件 c.xlskill d ：folder1c.xls 9, 删除文件夹 folderSet aaa = CreateObject(Scripting.FileSystemObject)aaa.DeleteFolder d：folderVBA Dir函数 遍历文件夹下的所有文件2010-05-26 17：305.VBA Dir函数第 1.12 例 Dir 函数一、题目：要求编写一段代码，运用 Dir 函数返回一个文件夹的文件列表。二、代码：10/33Sub 示例 _1_12()Dim wjmwjm = Dir(C ：WINDOWS

22、WIN.ini)MsgBox wjmwjm = Dir(C ：WINDOWS*.ini)wjm = DirEnd Sub三、代码详解1、 Sub 示例 _1_12()：宏程序的开始语句。宏名为示例_1_12。2、 Dim wjm ：变量 wjm 声明为可变型数据类型。3、 wjm = Dir(C ：WINDOWSWIN.ini)：如果该文件存在则返回“WIN.INI ”(在 C：Windows 文件夹中 ) ，把返回的文件名赋给变量wjm 。如果该文件不存在则wjm=”。4、 wjm = Dir(C ：WINDOWS*.ini)：返回带指定扩展名的文件名。如果超过一个*.ini文件存在，函数将

23、返回按条件第一个找到的文件名。5、 wjm = Dir：若第二次调用Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个*.ini文件。Dir 函数返回一个字符串String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。Dir(pathname, attributes)Dir 函数的语法具有以下几个部分：11/ 33pathname 可选参数。用来指定文件名的字符串表达式， 可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 () 。attributes 可选参数。常数或数值表达式， 其总和用来指定文件属性

24、。如果省略，则会返回匹配 pathname 但不包含属性的文件。EXCEL 的 VBA 用于同时显示目录文件夹和文件列表2010-05-22 18：41”VBA 工具中要引用 microsoft scipting runtimeDim pt As RangeSub 查找文件夹下子文件夹及其大小()Dim theDir As StringSet pt = ActiveSheet.Range(a1)清除第一列theDir = Application.InputBox( 输入指定文件夹的路径：, 查看子文件夹及其大小 )pt = theDir列出选取的目录名listPath theDir用于列出子目

25、录和文件：b).AutoFitEnd SubSub listPath(strDir As String)Dim thePath As StringDim strSdir As StringDim theDirs As Scripting.FoldersDim theDir As Scripting.Folder12/33Dim row As IntegerDim s As StringDim myFso As Scripting.FileSystemObject Set myFso = New Scripting.FileSystemObject If Right(strDir, 1) The

26、n strDir = strDir & thePath = thePath & strDirrow = pt.row此段为获取此目录下的文件名s = Dir(thePath, 7)获取第一个文件Do While s row = row + 1Cells(row, 1) = s文件的名称Cells(row, 1).Font.Color = RGB(256, 12, 213)Cells(row, 1).Font.Bold = Tures = Dir下一个文件LoopSet pt = Cells(row, 1)Set pt = pt.Offset(1, 0)Set theDirs = myFso.g

27、etfolder(strDir).subfolders For Each theDir In theDirs pt = theDir.Pathpt.Next = theDir.SizelistPath theDir.PathNextSet myFso = Nothing13/33End SubPrivate Sub CommandButton1_Click()查找文件夹下子文件夹及其大小End Sub6.用 VBA 获取文件夹中的文件列表如果我们要在 Excel 中获取某个文件夹中所有的文件列表，可以通过下面的 VBA 代码来进行。代码运行后，首先弹出一个浏览文件夹对话框，然后新建一个工作簿，

28、并在工作表的 A 至 F 列分别列出选定文件夹中的所有文件的文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下：1.按 Alt+F11 ，打开 VBA 编辑器，单击菜单“插入模块” ，将下面的代码粘贴到右侧的代码窗口中：Option ExplicitSub GetFileList()Dim strFolder As StringDim varFileList As V ariantDim FSO As Object, myFile As ObjectDim myResults As VariantDim l As Long显示打开文件夹对话框With Application.F

29、ileDialog(msoFileDialogFolderPicker).ShowIf .SelectedItems.Count = 0 Then Exit Sub 未选择文件夹strFolder = .SelectedItems(1)End With14/33获取文件夹中的所有文件列表varFileList = fcnGetFileList(strFolder)If Not IsArray(varFileList) ThenMsgBox 未找到文件 , vbInformationExit SubEnd If获取文件的详细信息，并放到数组中ReDim myResults(0 To UBound

30、(varFileList) + 1, 0 To 5)myResults(0, 0) = 文件名 myResults(0, 1) = 大小（字节） myResults(0, 2) = 创建时间 myResults(0, 3) = 修改时间 myResults(0, 4) = 访问时间 myResults(0, 5) = 完整路径 Set FSO = CreateObject(Scripting.FileSystemObject)For l = 0 To UBound(varFileList)Set myFile = FSO.GetFile(CStr(varFileList(l) myResult

31、s(l + 1, 0) = CStr(varFileList(l) myResults(l + 1, 1) = myFile.Size myResults(l + 1, 2) = myFile.DateCreated myResults(l + 1, 3) = myFile.DateLastModified myResults(l + 1, 4) = myFile.DateLastAccessed myResults(l + 1, 5) = myFile.Path Next l15/33fcnDumpToWorksheet myResultsSet myFile = NothingSet FS

32、O = NothingEnd SubPrivate Function fcnGetFileList(ByVal strPath As String, Optional strFilter AsString) As Variant 如果文件夹中包含文件返回一个二维数组，否则返回FalseDim f As StringDim i As IntegerDim FileList() As StringIf strFilter = Then strFilter = *.*Select Case Right$(strPath, 1)Case , /strPath = Left$(strPath, Len(

33、strPath) - 1)End SelectReDim Preserve FileList(0)f = Dir$(strPath & & strFilter)Do While Len(f) 0ReDim Preserve FileList(i) As StringFileList(i) = fi = i + 1f = Dir$()LoopIf FileList(0) Empty Then16/33fcnGetFileList = FileListElsefcnGetFileList = FalseEnd IfEnd FunctionPrivate Sub fcnDumpToWorksheet

34、(varData As Variant, Optional mySh As Worksheet)Dim iSheetsInNew As IntegerDim sh As Worksheet, wb As WorkbookDim myColumnHeaders() As StringDim l As Long, NoOfRows As LongIf mySh Is Nothing Then新建一个工作簿iSheetsInNew = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1Application.Shee

35、tsInNewWorkbook = iSheetsInNewSet sh = wb.Sheets(1)ElseSet mySh = shEnd IfWith shRange(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1) = varData17/33End WithSet sh = NothingSet wb = NothingEnd Sub2.关闭 VBA 编辑器，回到 Excel 工作表中，按Alt+F8 ，打开“宏”对话框，选择“ GetFileList ”，单击“运行”按钮。7.VBA 中如何取文

36、件的最后修改时间?已经解决了，新的代码-Sub searchfiles()With Application.FileSearch.NewSearch.LookIn = D ：ttt.Filename = *.xls.SearchSubFolders = True.FileType = msoFileTypeAllFilesIf .Execute() 0 ThenFor i = 1 To .FoundFiles.CountWorksheets(sheet3).Cells(i, 2).Value = .FoundFiles(i)Dim fs, f, sSet fs = CreateObject(S

37、cripting.FileSystemObject)Set f = fs.GetFile(.FoundFiles(i)s = Created： & f.DateCreated18/33Worksheets(sheet3).Cells(i, 3).Value = sSet f = NothingSet fs = NothingNext iElseMsgBox no file found.End IfEnd WithEnd Sub8.VBA 代码调用浏览文件夹对话框的几种方法2009-05-25 15：241、使用 API 方法【类型声明】Private Type BROWSEINFOhWndOw

38、nerAs LongpIDLRootAs LongpszDisplayName As LonglpszTitleAs LongulFlagsAs LonglpfnCallbackAs LonglParamAs LongiImageAs LongEnd Type【API 声明】19/33Private Declare Function SHGetPathFromIDList Lib shell32.dll _ Alias SHGetPathFromIDListA (ByVal pidl As Long, _ ByVal pszPath As String) As LongPrivate Decl

39、are Function SHBrowseForFolder Lib shell32.dll _Alias SHBrowseForFolderA (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function lstrcat Lib kernel32 _Alias lstrcatA (ByVal lpString1 As String, _ ByVal lpString2 As String) As LongPrivate Declare Function OleInitialize Lib ole32.dll _ (lp As An

40、y) As LongPrivate Declare Sub OleUninitialize Lib ole32 () Private Const BIF_USENEWUI = &H40 Private Const MAX_PATH = 260 【自定义函数】Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As StringDim lpIDList As LongDim sBuffer As StringDim BInfo As BROWSEINFOIf IsMissing(vFlags) T

41、hen vFlags = BIF_USENEWUI Call OleInitialize(ByVal 0&) With BInfo.lpszTitle = lstrcat(sTitle, ).ulFlags = vFlags20/33End WithlpIDList = SHBrowseForFolder(BInfo)If (lpIDList) ThensBuffer = Space(MAX_PATH)SHGetPathFromIDList lpIDList, sBuffersBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)If sB

42、uffer Then GetFolder_API = sBufferEnd IfCall OleUninitializeEnd Function【使用方法】Sub Test()MsgBox GetFolder_API( 选择文件夹 )End Sub2、使用 Shell.Application 方法Sub GetFloder_Shell()Set objShell = CreateObject(Shell.Application)Set objFolder = objShell.BrowseForFolder(0, 选择文件夹 , 0, 0)If Not objFolder Is Nothing

43、 ThenEnd IfSet objFolder = NothingSet objShell = NothingEnd Sub21/333、使用 FileDialog 方法Sub GetFloder_FileDialog()Dim fd As FileDialogSet fd = Application.FileDialog(msoFileDialogFolderPicker)If fd.Show = -1 Then MsgBox fd.SelectedItems(1)Set fd = NothingEnd Sub以上方法在 WINXP+OFFICE2003 中测试通过Excel VBA 选择

44、目标文件夹方法2009-04-13 08：499.用 VBA 选择目标文件夹几种实现代码：1.FileDialog 属性Sub Sample1()With Application.FileDialog(msoFileDialogFolderPicker)If .Show = True ThenMsgBox .SelectedItems(1)txtFolder.Text = .SelectedItems(1)End IfEnd WithEnd Sub2.shell 方法Sub Sample2()Dim Shell, myPath22/33Set Shell = CreateObject(Shel

45、l.Application)Set myPath = Shell.BrowseForFolder(&O0, 请选择文件夹 , &H1 + &H10, G ：)Set Shell = NothingSet myPath = NothingEnd Sub3.API 方法Declare Function SHGetPathFromIDList Lib shell32.dll Alias SHGetPathFromIDListA _(ByVal pidl As Long, ByVal pszPath As String) As LongDeclare Function SHBrowseForFolde

46、r Lib shell32.dll Alias SHBrowseForFolderA _(lpBrowseInfo As BROWSEINFO) As LongDeclare Function GetDesktopWindow Lib user32 () As LongPublic Type BROWSEINFOhOwner As LongpidlRoot As LongpszDisplayName As StringlpszTitle As StringulFlags As Longlpfn As LonglParam As LongiImage As Long23/33End TypeSu

47、b Sample3()Dim buf As Stringbuf = GetFolder(请选择文件夹 )If buf = Then Exit SubMsgBox bufEnd SubFunction GetFolder(Optional Msg) As StringDim bInfo As BROWSEINFO, pPath As StringDim R As Long, X As Long, pos As IntegerbInfo.pidlRoot = 0&bInfo.lpszTitle = MsgbInfo.ulFlags = &H1X = SHBrowseForFolder(bInfo)

48、pPath = Space$(512)R = SHGetPathFromIDList(ByVal X, ByVal pPath)If R Thenpos = InStr(pPath, Chr$(0)GetFolder = Left(pPath, pos - 1)ElseGetFolder = End IfEnd Function10. VBA 代码调用浏览文件夹对话框的几种方法24/331、使用 API 方法【类型声明】Private Type BROWSEINFOhWndOwnerAs LongpIDLRootAs LongpszDisplayName As LonglpszTitleAs

49、LongulFlagsAs LonglpfnCallbackAs LonglParamAs LongiImageAs LongEnd Type【API 声明】Private Declare Function SHGetPathFromIDList Lib shell32.dll _ Alias SHGetPathFromIDListA (ByVal pidl As Long, _ ByVal pszPath As String) As LongPrivate Declare Function SHBrowseForFolder Lib shell32.dll _Alias SHBrowseFo

50、rFolderA (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function lstrcat Lib kernel32 _Alias lstrcatA (ByVal lpString1 As String, _ ByVal lpString2 As String) As LongPrivate Declare Function OleInitialize Lib ole32.dll _ (lp As Any) As LongPrivate Declare Sub OleUninitialize Lib ole32 ()25/33P

51、rivate Const BIF_USENEWUI = &H40Private Const MAX_PATH = 260【自定义函数】Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As StringDim lpIDList As LongDim sBuffer As StringDim BInfo As BROWSEINFOIf IsMissing(vFlags) Then vFlags = BIF_USENEWUI Call OleInitialize(ByVal 0&) With BI

52、nfo.lpszTitle = lstrcat(sTitle, ).ulFlags = vFlagsEnd WithlpIDList = SHBrowseForFolder(BInfo)If (lpIDList) ThensBuffer = Space(MAX_PATH)SHGetPathFromIDList lpIDList, sBuffersBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)If sBuffer Then GetFolder_API = sBufferEnd IfCall OleUninitializeEnd Function【使用方法】26/33Sub Test()MsgBox GetFolder_API( 选择文件夹 )End Sub2、使用 Shell.Application 方法Sub Ge