VBA文件及文件夹操作

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 ：

2、 folderb.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

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

4、Name + )NextG,删除文件 c.xlskill d ：folder1c.xlsH,删除文件夹 folderSet aaa = CreateObject(Scripting.FileSystemObject)aaa.DeleteFolder d：folder2. 8excel 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 ： 注意路径，换成你实际的路径.精品文档s.Filename = *.* 搜索所有文件s.Execute 执行搜索Cells.Delete 表格清空For i = 1 To s.FoundFiles.CountCells(i, 1

6、) = s.FoundFiles(i) 每一行第一列填写一个文件名NextEnd 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 NameSpac

7、eDim oFolder As MAPIFolderDim oMailItem 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 sensitiveSendFile = HZ121-1_Daily.xls.精品文档MyY

8、= 0Set oApp = New Outlook.ApplicationSet 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 ThenIf oMa

9、ilItem.Attachments.Count 0 Then protect error For i = 1 To oMailItem.Attachments.CountIf oMailItem.Attachments.Item(i).FileName = SendFile Then MyT1 = InStr(1, oMailItem.Attachments.Item(i).FileName, ., 1)MyT2 = Left(oMailItem.Attachments.Item(i).FileName, 19) + - + MyT3 + .xlsoMailItem.Attachments.

10、Item(i).SaveAsFile MyDir & MyT2MsgBox oMailItem.Attachments.Item(i).DisplayName & was saved as & oMailItem.Attachments.Item(i).FileNameEnd IfNext iEnd IfEnd IfElseMyY = MyY + 1If MyY 10 Then GoTo LoopEnd.精品文档End IfEnd WithNext oMailItemLoopEnd： Set oMailItem = Nothing Set oFolder = Nothing Set oName

11、Space = Nothing Set oApp = Nothing3.Excel VBA 把选定文件夹中的工作簿导入到新建 ACCESS 数据库中2010-04-24 22：33方法一Sub Create_AccessProject()Dim AccessData As ObjectSet AccessData = CreateObject(Access.Application)Dim Stpath As StringStpath = ThisWorkbook.Path & DSEM-Stock-Allocation.mdb 设定路径 If Dir(Stpath, vbDirectory)

12、= DSEM-Stock-Allocation.mdb Then Kill (Stpath)End IfAccessData.NewCurrentDatabase StpathSet AccessData = Nothing 创建表格Set cnnaccess = CreateObject(Adodb.Connection)Set rstAnswers = CreateObject(Adodb.Recordset).精品文档cnnaccess.Provider = Microsoft.Jet.OLEDB.4.0Application.Wait Now() + TimeValue(00 ：00：

13、02) 系统暂停 2 秒,以等待data.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.DisplayAl

14、erts = FalsemyFile = 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

15、, Len(CurFile) - 4)If CurFile = HONHAI-VMIData1.xls ThenWith objAccess.OpenCurrentDatabase (ThisWorkbook.Path & DSEM-Stock-Allocation.mdb).精品文档.DoCmd.TransferSpreadsheet acLink, 8, TableName, LinkFile, True, Aging Report$End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingCurFile = DirElseW

16、ith objAccess.OpenCurrentDatabase (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.DatabaseDim ws As DAO.Wor

17、kspaceSet ws = 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 ：CustomersDataBa

18、seTest注意路径，换成你实际的路径s.Filename = *.* 搜索所有文件s.Execute 执行搜索For i = 1 To s.FoundFiles.CountFullName1=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 & Fi

19、lename & .xlsWith objAccess.OpenCurrentDatabase(C：CustomersDataBaseDSEM-PO-Stock-Status.mdb).DoCmd.TransferSpreadsheet acImport, 8, DSEM-MovingPlan, myFile, True, End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingNextEnd Sub.精品文档4. vba 操作文件及文件夹示例2009-08-20 00：07vba 操作文件及文件夹示例利用 excel 中的 v

20、ba 可以对电脑中的文件及文件夹做一些常用的操作。包括复制、重命名、删除等，其中一些简单的示例总结如下。希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！以下代码建议在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.S

21、aveAs Filename：=D ： foldera.xlsActiveWorkbook.SaveAs Filename：=D ： folderb.xls3,创建新文件夹 folder1 并把 a.xls 复制到新文件夹重新命名为c.xlsMkDir D ：folder1FileCopy D ：foldera.xls, D ：folder1c.xls4,复制 folder 中所有文件到 folder1Set qqq = CreateObject(Scripting.FileSystemObject)qqq.CopyFolder D：folder, D ：folder15,重命名 a.xls

22、为 d.xlsname d：folder1a.xls as d：folder1d.xls6,判断文件及文件夹是否存在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：fo

23、lder1)For Each i In r.FilesWorkbooks.Open Filename：=(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 函数返回一个文件夹的文件列

24、表。二、代码：Sub 示例 _1_12()Dim wjmwjm = Dir(C ：WINDOWSWIN.ini)MsgBox wjmwjm = Dir(C ：WINDOWS*.ini)wjm = Dir.精品文档End 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 =

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

26、长度字符串 () 。attributes 可选参数。常数或数值表达式， 其总和用来指定文件属性。如果省略，则会返回匹配 pathname 但不包含属性的文件。EXCEL 的 VBA 用于同时显示目录文件夹和文件列表2010-05-22 18：41.精品文档”VBA 工具中要引用 microsoft scipting runtimeDim pt As RangeSub 查找文件夹下子文件夹及其大小()Dim theDir As StringSet pt = ActiveSheet.Range(a1)pt.Worksheet.Columns(1).ClearContents清除第一列theDir

27、= Application.InputBox( 输入指定文件夹的路径：, 查看子文件夹及其大小 )pt = theDir列出选取的目录名listPath theDir用于列出子目录和文件pt.Worksheet.Columns(a：b).AutoFitEnd SubSub listPath(strDir As String)Dim thePath As StringDim strSdir As StringDim theDirs As Scripting.FoldersDim theDir As Scripting.FolderDim row As IntegerDim s As String

28、Dim myFso As Scripting.FileSystemObject Set myFso = New Scripting.FileSystemObject If Right(strDir, 1) Then 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)Ce

29、lls(row, 1).Font.Bold = Tures = Dir下一个文件LoopSet pt = Cells(row, 1)Set pt = pt.Offset(1, 0)Set theDirs = myFso.getfolder(strDir).subfoldersFor Each theDir In theDirspt = theDir.Pathpt.Next = theDir.SizelistPath theDir.PathNextSet myFso = NothingEnd SubPrivate Sub CommandButton1_Click()查找文件夹下子文件夹及其大小E

30、nd Sub6.用 VBA 获取文件夹中的文件列表如果我们要在 Excel 中获取某个文件夹中所有的文件列表，可以通过下面的 VBA 代码来进行。代码运行后，首先弹出一个浏览文件夹对话框，然后新建一个工作簿，并在工作表的 A 至 F 列分别列出选定文件夹中的所有文件的.精品文档文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下：1.按 Alt+F11 ，打开 VBA 编辑器，单击菜单“插入模块” ，将下面的代码粘贴到右侧的代码窗口中：Option ExplicitSub GetFileList()Dim strFolder As StringDim varFileList As

31、 V ariantDim FSO As Object, myFile As ObjectDim myResults As VariantDim l As Long显示打开文件夹对话框With Application.FileDialog(msoFileDialogFolderPicker).ShowIf .SelectedItems.Count = 0 Then Exit Sub 未选择文件夹strFolder = .SelectedItems(1)End With获取文件夹中的所有文件列表varFileList = fcnGetFileList(strFolder)If Not IsArra

32、y(varFileList) ThenMsgBox 未找到文件 , vbInformationExit SubEnd If获取文件的详细信息，并放到数组中ReDim myResults(0 To UBound(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(Scr

33、ipting.FileSystemObject)For l = 0 To UBound(varFileList)Set myFile = FSO.GetFile(CStr(varFileList(l) myResults(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.DateLas

34、tAccessed myResults(l + 1, 5) = myFile.Path Next lfcnDumpToWorksheet myResultsSet myFile = NothingSet FSO = NothingEnd SubPrivate Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant 如果文件夹中包含文件返回一个二维数组，否则返回FalseDim f As StringDim i As IntegerDim FileList() As Str

35、ing.精品文档If strFilter = Then strFilter = *.*Select Case Right$(strPath, 1)Case , /strPath = Left$(strPath, Len(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) Empt

36、y ThenfcnGetFileList = FileListElsefcnGetFileList = FalseEnd IfEnd FunctionPrivate Sub fcnDumpToWorksheet(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 Long.精品文档If mySh Is Nothing

37、 Then新建一个工作簿iSheetsInNew = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1Set wb = Application.Workbooks.AddApplication.SheetsInNewWorkbook = iSheetsInNewSet sh = wb.Sheets(1)ElseSet mySh = shEnd IfWith shRange(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)

38、= varData.UsedRange.Columns.AutoFitEnd WithSet sh = NothingSet wb = NothingEnd Sub2.关闭 VBA 编辑器，回到 Excel 工作表中，按Alt+F8 ，打开“宏”对话框，选择“ GetFileList ”，单击“运行”按钮。7.VBA 中如何取文件的最后修改时间?已经解决了，新的代码-Sub searchfiles().精品文档With Application.FileSearch.NewSearch.LookIn = D ：ttt.Filename = *.xls.SearchSubFolders = Tru

39、e.FileType = msoFileTypeAllFilesIf .Execute() 0 ThenFor i = 1 To .FoundFiles.CountWorksheets(sheet3).Cells(i, 2).Value = .FoundFiles(i)Dim fs, f, sSet fs = CreateObject(Scripting.FileSystemObject)Set f = fs.GetFile(.FoundFiles(i)s = Created： & f.DateCreatedWorksheets(sheet3).Cells(i, 3).Value = sSet

40、 f = NothingSet fs = NothingNext iElseMsgBox no file found.End IfEnd WithEnd Sub8.VBA 代码调用浏览文件夹对话框的几种方法2009-05-25 15：24.精品文档1、使用 API 方法【类型声明】Private Type BROWSEINFOhWndOwnerAs LongpIDLRootAs LongpszDisplayName As LonglpszTitleAs LongulFlagsAs LonglpfnCallbackAs LonglParamAs LongiImageAs LongEnd Type

41、【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 SHBrowseForFolderA (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function

42、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 ()Private Const BIF_USENEWUI = &H40.精品文档Private Const MAX_PATH = 260【自定义函数】Publ

43、ic 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 BInfo.lpszTitle = lstrcat(sTitle, ).ulFlags = vFlagsEnd WithlpIDList = SH

44、BrowseForFolder(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【使用方法】Sub Test()MsgBox GetFolder_API( 选择文件夹 ).精品文档End Sub2、使用 Shel

45、l.Application 方法Sub GetFloder_Shell()Set objShell = CreateObject(Shell.Application)Set objFolder = objShell.BrowseForFolder(0, 选择文件夹 , 0, 0)If Not objFolder Is Nothing ThenMsgBox objFolder.self.pathEnd IfSet objFolder = NothingSet objShell = NothingEnd Sub3、使用 FileDialog 方法Sub GetFloder_FileDialog()

46、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 选择目标文件夹方法2009-04-13 08：499.用 VBA 选择目标文件夹几种实现代码：1.FileDialog 属性.精品文档Sub Sample1()With Application.FileDialog(msoFil

47、eDialogFolderPicker)If .Show = True ThenMsgBox .SelectedItems(1)txtFolder.Text = .SelectedItems(1)End IfEnd WithEnd Sub2.shell 方法Sub Sample2()Dim Shell, myPathSet Shell = CreateObject(Shell.Application)Set myPath = Shell.BrowseForFolder(&O0, 请选择文件夹 , &H1 + &H10,G ：)If Not myPath Is Nothing Then MsgBox myPath.Items.Item.PathSet Shell = NothingSet myPath = NothingEnd Sub3.API 方法Declare Function SHGetPathFromIDList Lib shell32.dll Alias SHGetPathFromIDListA _(ByVal pidl As Long, ByVal ps