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：\folder\a.xls"ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"C,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xls MkDir "D：\folder1"FileCopy "D：\folder\a.xls", "D：\folder1\c.xls"D,复制folder中所有文件到folder1Set qqq = CreateObject("Scripting.FileSystemObject")qqq.CopyFolder "D：\folder", "D：\folder1"D,重命名a.xls为d.xlsname "d：\folder1\a.xls" as "d：\folder1\d.xls"E,判断文件及文件夹是否存在Set yyy = CreateObject("Scripting.FileSystemObject")If yyy.FolderExists("D：\folder1) = True Then ...If yyy.FileExists("D：\folder1\d.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\" + + "")NextG,删除文件c.xlskill "d：\folder1\c.xls"H,删除文件夹folderSet aaa = CreateObject("Scripting.FileSystemObject")aaa.DeleteFolder "d：\folder"2.8excel vba一次性获取文件夹下的所有文件名的方法小生今天上网下载了一个财务常用报表的文件包，里面有几百个excel工作表，要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。

于是想到昨论坛就是vba论坛，昨不充分利用excel 自身的高级应用呀，呵呵，实现的代码如下，把工作量几天的任务可是一下子就完成了，这就是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) = s.FoundFiles(i) '每一行第一列填写一个文件名NextEnd Sub现在获得的可是带路径的工作表名，去掉前的路径可用以下方法；=RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,"\","#",LEN(A1)-LEN(SUBSTITU TE(A1,"\",)))))最后用常规的方法往下拖，就完成了笔者所需的工作表名。

outlook下VBA编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上2009-06-17 09：35Sub SaveAttachments()Dim oApp As Outlook.ApplicationDim oNameSpace As NameSpaceDim oFolder As MAPIFolderDim oMailItem As ObjectDim sMessage As StringBeforeDate = #10/1/2007# ' choose the end date of wantedMyDir = "E：\liuxc-work\oil loss\backup from public folder\" ' choose the folder location for saveSender = "Hz121 Supervisor" ' caution, case sensitiveSendFile = "HZ121-1_Daily.xls"MyY = 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 ThenIf oMailItem.SenderName = Sender ThenIf oMailItem.Attachments.Count > 0 Then ' protect errorFor i = 1 To oMailItem.Attachments.CountIf oMailItem.Attachments.Item(i).FileName = SendFile ThenMyT1 = InStr(1, oMailItem.Attachments.Item(i).FileName, ".", 1)MyT2 = Left(oMailItem.Attachments.Item(i).FileName, 19) + "-" + MyT3 + ".xls"oMailItem.Attachments.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 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.Application")Dim Stpath As StringStpath = ThisWorkbook.Path & "\DSEM-Stock-Allocation.mdb" '设定路径If Dir(Stpath, vbDirectory) = "DSEM-Stock-Allocation.mdb" ThenKill (Stpath)End IfAccessData.NewCurrentDatabase StpathSet AccessData = Nothing '创建表格Set cnnaccess = CreateObject("Adodb.Connection")Set rstAnswers = CreateObject("Adodb.Recordset")cnnaccess.Provider = "Microsoft.Jet.OLEDB.4.0"Application.Wait Now() + TimeValue("00：00：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 = Dim CurFile As StringApplication.DisplayAlerts = 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, 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 = DirElseWith 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.WorkspaceSet ws = DBEngine.Workspaces(0)Set db = ws.OpenDatabase("C：\CustomersDataBase\DSEM-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：\CustomersDataBase\Test\" '注意路径，换成你实际的路径s.Filename = "*.*" '搜索所有文件s.Execute '执行搜索For i = 1 To s.FoundFiles.CountFullName1 = Right(s.FoundFiles(i), Len(s.FoundFiles(i)) - Len("C：\CustomersDataBase\Test\"))Filename = Left(FullName1, Len(FullName1) - 4)Set objAccess = CreateObject("Access.Application")myFile = "C：\CustomersDataBase\Test\" & Filename & ".xls"With objAccess.OpenCurrentDatabase ("C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb").DoCmd.TransferSpreadsheet acImport, 8, "DSEM-MovingPlan", myFile, True, ""End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingNextEnd Sub4.vba操作文件及文件夹示例2009-08-20 00：07vba操作文件及文件夹示例利用excel中的vba可以对电脑中的文件及文件夹做一些常用的操作。