VBA文件及文件夹操作

VBA文件及文件夹操作1.VBA操作文件及文件夹onerrorresumenext下测试A，在D：\下新建文件夹，命名为folder方法1：MkDirD：\folder方法2：Setabc=CreateObject(Scripting.FileSystemObject)abc.CreateFolder(D：\folder)B，新建2个文件命名为a.xls和b.xlsWorkbooks.AddActiveWorkbook.SaveAsFilename：=D：\folder\a.xlsActiveWorkbook.SaveAsFilename：=D：\folder\b.xlsC,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xlsMkDirD：\folder1FileCopyD：\folder\a.xls,D：\folder1\c.xlsD,复制folder中所有文件到folder1Setqqq=CreateObject(Scripting.FileSystemObject)qqq.CopyFolderD：\folder,D：\folder1D,重命名a.xls为d.xlsnamed：\folder1\a.xlsasd：\folder1\d.xlsE,判断文件及文件夹是否存在Setyyy=CreateObject(Scripting.FileSystemObject)Ifyyy.FolderExists(D：\folder1)=TrueThen...Ifyyy.FileExists(D：\folder1\d.xls)=TrueThen...F,打开folder1中所有文件Setrrr=CreateObject(Scripting.FileSystemObject)Setr=rrr.GetFolder(d：\folder1)ForEachiInr.FilesWorkbooks.OpenFilename：=(d：\folder1\+i.Name+)NextG,删除文件c.xlskilld：\folder1\c.xlsH,删除文件夹folderSetaaa=CreateObject(Scripting.FileSystemObject)aaa.DeleteFolderd：\folder2.excelvba一次性获取文件夹下的所有文件名的方法小生今天上网下载了一个财务常用报表的文件包，里面有几百个excel工作表，要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。于是想到昨论坛就是vba论坛，昨不充分利用excel自身的高级应用呀，呵呵，实现的代码如下，把工作量几天的任务可是一下子就完成了，这就是excelvba给你工作提高效率的结果！exclevba自动获取同一文件夹下所有工作表的名称红色代码：按Alt+F11，打开VBA编辑器，插入一个模块，把下面的代码贴进去，按F5执行Subt()DimsAsFileSearch'定义一个文件搜索对象Sets=Application.FileSearchs.LookIn=c：\'注意路径，换成你实际的路径s.Filename=*.*'搜索所有文件s.Execute'执行搜索Cells.Delete'表格清空Fori=1Tos.FoundFiles.CountCells(i,1)=s.FoundFiles(i)'每一行第一列填写一个文件名NextEndSub现在获得的可是带路径的工作表名，去掉前的路径可用以下方法；=RIGHT(A1,LEN(A1)-FIND(#,SUBSTITUTE(A1,\,#,LEN(A1)-LEN(SUBSTITUTE(A1,\,)))))最后用常规的方法往下拖，就完成了笔者所需的工作表名。outlook下VBA编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上2009-06-1709：35SubSaveAttachments()DimoAppAsOutlook.ApplicationDimoNameSpaceAsNameSpaceDimoFolderAsMAPIFolderDimoMailItemAsObjectDimsMessageAsStringBeforeDate=#10/1/2007#'choosetheenddateofwantedMyDir=E：\liuxc-work\oilloss\backupfrompublicfolder\'choosethefolderlocationforsaveSender=Hz121Supervisor'caution,casesensitiveSendFile=HZ121-1_Daily.xlsMyY=0SetoApp=NewOutlook.ApplicationSetoNameSpace=oApp.GetNamespace(MAPI)SetoFolder=oNameSpace.PickFolderForEachoMailItemInoFolder.ItemsWithoMailItemMyT3=Left(CStr(oMailItem.CreationTime),10)IfCDate(oMailItem.CreationTime)=BeforeDateThenIfoMailItem.SenderName=SenderThenIfoMailItem.Attachments.Count0Then'protecterrorFori=1TooMailItem.Attachments.CountIfoMailItem.Attachments.Item(i).FileName=SendFileThenMyT1=InStr(1,oMailItem.Attachments.Item(i).FileName,.,1)MyT2=Left(oMailItem.Attachments.Item(i).FileName,19)+-+MyT3+.xlsoMailItem.Attachments.Item(i).SaveAsFileMyDir&MyT2MsgBoxoMailItem.Attachments.Item(i).DisplayName&wassavedas&oMailItem.Attachments.Item(i).FileNameEndIfNextiEndIfEndIfElseMyY=MyY+1IfMyY10ThenGoToLoopEndEndIfEndWithNextoMailItemLoopEnd：'SetoMailItem=Nothing'SetoFolder=Nothing'SetoNameSpace=Nothing'SetoApp=Nothing3.ExcelVBA把选定文件夹中的工作簿导入到新建ACCESS数据库中2010-04-2422：33方法一SubCreate_AccessProject()DimAccessDataAsObjectSetAccessData=CreateObject(Access.Application)DimStpathAsStringStpath=ThisWorkbook.Path&\DSEM-Stock-Allocation.mdb'设定路径IfDir(Stpath,vbDirectory)=DSEM-Stock-Allocation.mdbThenKill(Stpath)EndIfAccessData.NewCurrentDatabaseStpathSetAccessData=Nothing'创建表格Setcnnaccess=CreateObject(Adodb.Connection)SetrstAnswers=CreateObject(Adodb.Recordset)cnnaccess.Provider=Microsoft.Jet.OLEDB.4.0Application.WaitNow()+TimeValue(00：00：02)'系统暂停2秒,以等待data.mdb建立成功cnnaccess.OpenDataSource=&Stpath&;JetOLEDB：DatabasePassword=&'strSQL=CreateTablemyData(last_datechar(8))'rstAnswers.OpenstrSQL,cnnaccessSetrstAnswers=NothingSetcnnaccess=NothingMyMainFile=ThisWorkbook.NameDimCurFileAsStringApplication.DisplayAlerts=FalsemyFile=Application.GetOpenFilename((*.xls),*.xls),,PleaseSelectFiles)IfmyFile=FalseThenExitSubDirLoc=CurDir(myFile)&\CurFile=Dir(DirLoc&*.xls)DoWhileCurFilevbNullStringSetobjAccess=CreateObject(Access.Application)LinkFile=DirLoc&CurFileTableName=Left(CurFile,Len(CurFile)-4)IfCurFile=HONHAI-VMIData1.xlsThenWithobjAccess.OpenCurrentDatabase(ThisWorkbook.Path&\DSEM-Stock-Allocation.mdb).DoCmd.TransferSpreadsheetacLink,8,TableName,LinkFile,True,AgingReport$EndWithobjAccess.CloseCurrentDatabaseSetobjAccess=NothingCurFile=DirElseWithobjAccess.OpenCurrentDatabase(ThisWorkbook.Path&\DSEM-Stock-Allocation.mdb).DoCmd.TransferSpreadsheetacImport,8,TableName,LinkFile,True,EndWithobjAccess.CloseCurrentDatabaseSetobjAccess=NothingCurFile=DirEndIfLoopEndSub方法二SubFolder2Access()DimdbAsDAO.DatabaseDimwsAsDAO.WorkspaceSetws=DBEngine.Workspaces(0)Setdb=ws.OpenDatabase(C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb,False,False,)db.Execute(delete*from[DSEM-MovingPlan])db.CloseSetdb=NothingDimmyFileAsStringDimsAsFileSearch'定义一个文件搜索对象Sets=Application.FileSearchs.LookIn=C：\CustomersDataBase\Test\'注意路径，换成你实际的路径s.Filename=*.*'搜索所有文件s.Execute'执行搜索Fori=1Tos.FoundFiles.CountFullName1=Right(s.FoundFiles(i),Len(s.FoundFiles(i))-Len(C：\CustomersDataBase\Test\))Filename=Left(FullName1,Len(FullName1)-4)SetobjAccess=CreateObject(Access.Application)myFile=C：\CustomersDataBase\Test\&Filename&.xlsWithobjAccess.OpenCurrentDatabase