VBA文件及文件夾操作

1、精品文檔VBA 文件及文件夾操作1.VBA 操作文件及文件夾on error resume next下測(cè)試A，在 D： 下新建文件夾，命名為folder方法 1：MkDir D ：folder方法 2：Set abc = CreateObject(Scripting.FileSystemObject)abc.CreateFolder (D：folder)B，新建 2 個(gè)文件命名為 a.xls 和 b.xlsWorkbooks.AddActiveWorkbook.SaveAs Filename：=D ： foldera.xlsActiveWorkbook.SaveAs Filename：=D ：

2、 folderb.xlsC,創(chuàng)建新文件夾 folder1 并把 a.xls 復(fù)制到新文件夾重新命名為c.xlsMkDir D ：folder1FileCopy D ：foldera.xls, D ：folder1c.xlsD,復(fù)制 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 一次性獲取文件夾下的所有文件名的方法小生今天上網(wǎng)下載了一個(gè)財(cái)務(wù)常用報(bào)表的文件包，里面有幾百個(gè) excel 工作表，要是手工一個(gè)一個(gè)的獲得文件名的話，那我可是要忙十天半月哦。于是想到昨論壇就是 vba 論壇，昨不充分利用 excel 自身的高級(jí)應(yīng)用呀， 呵呵，實(shí)現(xiàn)的代碼如下，把工作量幾天的任務(wù)可是一下子就完

5、成了，這就是 excel vba給你工作提高效率的結(jié)果！excle vba 自動(dòng)獲取同一文件夾下所有工作表的名稱紅色代碼：按 Alt+F11 ，打開 VBA 編輯器，插入一個(gè)模塊，把下面的代碼貼進(jìn)去，按F5執(zhí)行Sub t()Dim s As FileSearch 定義一個(gè)文件搜索對(duì)象Set s = Application.FileSearchs.LookIn = c ： 注意路徑，換成你實(shí)際的路徑.精品文檔s.Filename = *.* 搜索所有文件s.Execute 執(zhí)行搜索Cells.Delete 表格清空For i = 1 To s.FoundFiles.CountCells(i, 1

6、) = s.FoundFiles(i) 每一行第一列填寫一個(gè)文件名NextEnd Sub現(xiàn)在獲得的可是帶路徑的工作表名，去掉前的路徑可用以下方法；=RIGHT(A1,LEN(A1)-FIND(#,SUBSTITUTE(A1,#,LEN(A1)-LEN(SUBSTITUTE(A1,)最后用常規(guī)的方法往下拖，就完成了筆者所需的工作表名。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 把選定文件夾中的工作簿導(dǎo)入到新建 ACCESS 數(shù)據(jù)庫(kù)中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 設(shè)定路徑 If Dir(Stpath, vbDirectory)

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

13、02) 系統(tǒng)暫停 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 定義一個(gè)文件搜索對(duì)象 Set s = Application.FileSearchs.LookIn = C ：CustomersDataBa

18、seTest注意路徑，換成你實(shí)際的路徑s.Filename = *.* 搜索所有文件s.Execute 執(zhí)行搜索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 可以對(duì)電腦中的文件及文件夾做一些常用的操作。包括復(fù)制、重命名、刪除等，其中一些簡(jiǎn)單的示例總結(jié)如下。希望對(duì)一些經(jīng)常需要批量處理文件的朋友有所幫助，也希望感興趣的朋友多多指教！以下代碼建議在on error resume next下測(cè)試1，在 D： 下新建文件夾，命名為folder方法 1：MkDir D ：folder方法 2：Set abc = CreateObject(Scripting.FileSystemObject)abc.CreateFolder (D：folder)2，新建 2 個(gè)文件命名為 a.xls 和 b.xlsWorkbooks.AddActiveWorkbook.S

21、aveAs Filename：=D ： foldera.xlsActiveWorkbook.SaveAs Filename：=D ： folderb.xls3,創(chuàng)建新文件夾 folder1 并把 a.xls 復(fù)制到新文件夾重新命名為c.xlsMkDir D ：folder1FileCopy D ：foldera.xls, D ：folder1c.xls4,復(fù)制 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函數(shù) 遍歷文件夾下的所有文件2010-05-26 17：305.VBA Dir函數(shù)第 1.12 例 Dir 函數(shù)一、題目：要求編寫一段代碼，運(yùn)用 Dir 函數(shù)返回一個(gè)文件夾的文件列

24、表。二、代碼：Sub 示例 _1_12()Dim wjmwjm = Dir(C ：WINDOWSWIN.ini)MsgBox wjmwjm = Dir(C ：WINDOWS*.ini)wjm = Dir.精品文檔End Sub三、代碼詳解1、 Sub 示例 _1_12()：宏程序的開始語(yǔ)句。宏名為示例_1_12。2、 Dim wjm ：變量 wjm 聲明為可變型數(shù)據(jù)類型。3、 wjm = Dir(C ：WINDOWSWIN.ini)：如果該文件存在則返回“WIN.INI ”(在 C：Windows 文件夾中 ) ，把返回的文件名賦給變量wjm 。如果該文件不存在則wjm=”。4、 wjm =

25、Dir(C ：WINDOWS*.ini)：返回帶指定擴(kuò)展名的文件名。如果超過一個(gè)*.ini文件存在，函數(shù)將返回按條件第一個(gè)找到的文件名。5、 wjm = Dir：若第二次調(diào)用Dir 函數(shù)，但不帶任何參數(shù)，則函數(shù)將返回同一目錄下的下一個(gè)*.ini文件。Dir 函數(shù)返回一個(gè)字符串String，用以表示一個(gè)文件名、目錄名或文件夾名稱，它必須與指定的模式或文件屬性、或磁盤卷標(biāo)相匹配。Dir(pathname, attributes)Dir 函數(shù)的語(yǔ)法具有以下幾個(gè)部分：pathname 可選參數(shù)。用來指定文件名的字符串表達(dá)式， 可能包含目錄或文件夾、以及驅(qū)動(dòng)器。如果沒有找到 pathname，則會(huì)返回零

26、長(zhǎng)度字符串 () 。attributes 可選參數(shù)。常數(shù)或數(shù)值表達(dá)式， 其總和用來指定文件屬性。如果省略，則會(huì)返回匹配 pathname 但不包含屬性的文件。EXCEL 的 VBA 用于同時(shí)顯示目錄文件夾和文件列表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)獲取第一個(gè)文件.精品文檔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下一個(gè)文件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 中獲取某個(gè)文件夾中所有的文件列表，可以通過下面的 VBA 代碼來進(jìn)行。代碼運(yùn)行后，首先彈出一個(gè)瀏覽文件夾對(duì)話框，然后新建一個(gè)工作簿，并在工作表的 A 至 F 列分別列出選定文件夾中的所有文件的.精品文檔文件名、文件大小、創(chuàng)建時(shí)間、修改時(shí)間、訪問時(shí)間及完整路徑。方法如下：1.按 Alt+F11 ，打開 VBA 編輯器，單擊菜單“插入模塊” ，將下面的代碼粘貼到右側(cè)的代碼窗口中：Option ExplicitSub GetFileList()Dim strFolder As StringDim varFileList As

31、 V ariantDim FSO As Object, myFile As ObjectDim myResults As VariantDim l As Long顯示打開文件夾對(duì)話框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獲取文件的詳細(xì)信息，并放到數(shù)組中ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)myResults(0, 0) = 文件名 .精品文檔myResults(0, 1) = 大?。ㄗ止?jié)） myResults(0, 2) = 創(chuàng)建時(shí)間 myResults(0, 3) = 修改時(shí)間 myResults(0, 4) = 訪問時(shí)間 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 如果文件夾中包含文件返回一個(gè)二維數(shù)組，否則返回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新建一個(gè)工作簿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.關(guān)閉 VBA 編輯器，回到 Excel 工作表中，按Alt+F8 ，打開“宏”對(duì)話框，選擇“ GetFileList ”，單擊“運(yùn)行”按鈕。7.VBA 中如何取文件的最后修改時(shí)間?已經(jīng)解決了，新的代碼-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 代碼調(diào)用瀏覽文件夾對(duì)話框的幾種方法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【自定義函數(shù)】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 中測(cè)試通過Excel VBA 選擇目標(biāo)文件夾方法2009-04-13 08：499.用 VBA 選擇目標(biāo)文件夾幾種實(shí)現(xiàn)代碼：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, 請(qǐng)選擇文件夾 , &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