对文件夹中的所有文件执行function

我想为文件夹中的每个工作簿文件执行此function。 此脚本parsing单个工作簿中的数据。 我想为“attach”文件夹中的每个工作簿执行相同的任务。 这可以做一个循环？

Sub ParseTimeSheets() Dim FileName As String, FilePath As String, FolderPath As String FolderPath = "C:\attach\" FilePath = FolderPath & "*.xlsx" FileName = Dir(FilePath) Do While FileName <> "" Application.ScreenUpdating = 0 Dim WrkBookDest As Workbook Dim WrkBookSrs As Workbook Dim WrkSheetDest As Worksheet Dim WrkSheetSrs As Worksheet Dim WrkShArray As Worksheets Dim Rng As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range, Rng6 As Range Dim RngWeek As Range Set WrkBookDest = ThisWorkbook Set WrkBookSrs = Workbooks.Open(FolderPath & FileName) Set WrkSheetDest = WrkBookDest.Sheets("Sheet1") Set WrkSheetSrs = WrkBookSrs.Sheets("Title") 'selecting cells from Title sheet and parsing them to main workbook Set Rng = WrkSheetSrs.Range("A1") 'week Rng.Copy WrkBookDest.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Set Rng2 = WrkSheetSrs.Range("A2") 'week range Rng2.Copy WrkBookDest.Sheets("Sheet1").Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Set Rng3 = WrkSheetSrs.Range("B4") 'employee name Rng3.Copy WrkBookDest.Sheets("sheet1").Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Set Rng4 = WrkSheetSrs.Range("B5") 'Title Rng4.Copy WrkBookDest.Sheets("sheet1").Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Set Rng5 = WrkSheetSrs.Range("B6") 'Site Rng5.Copy WrkBookDest.Sheets("sheet1").Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Set Rng6 = WrkSheetSrs.Range("B7") 'Loc ID Rng6.Copy WrkBookDest.Sheets("sheet1").Range("F1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats 'For i = 3 To 9 'WrkBookSrs.Sheets(i).Range("A2:C57").Copy WrkBookDest.Sheets("sheet1").Range("G" & (i - 3) * 56 + 1) 'Next Dim i As Integer, j As Integer, k As Integer k = 1 'row counter for destination sheet 'loop sheets 3-9 For i = 3 To 9 'loop rows 2-57 For j = 2 To 57 'if C is not empty If WrkBookSrs.Sheets(i).Cells(j, 3).Value <> "" Then 'copy A:C on this row to the destination sheet column G row k WrkBookSrs.Sheets(i).Range("A" & j & ":C" & j).Copy WrkSheetDest.Range("G" & k) 'increment counter for next row k = k + 1 End If Next Next 'Close workbook sourse: Application.CutCopyMode = False WrkBookSrs.Close 'Sheets("sheet1").Range("M4") = date Loop ThisWorkbook.Sheets("Sheet1").Columns.AutoFit End Sub 

Answer 1

基本上你只需要这样做：

 FolderPath = "C:\attach\" FilePath = FolderPath & "*.xlsx" FileName = Dir(FilePath) Do While FileName <> "" 'your code here FileName = Dir() '<- add this... loops to next file in FilePath Loop 

Answer 2

如果您打开Excel工作簿，则可以使用Dir()函数查找文件。 （ VB版本的MSDN，但它在VBA中的工作情况，据我所知 ）这个小片段将显示在我的C:\目录中find的文件。

 Dim str As String str = Dir("C:\*", vbDirectory) Do While str <> "" MsgBox (str) str = Dir() Loop 

只要修改你的函数接受excel文件的path作为参数，这应该为你做的伎俩。

请注意，我在这个例子中使用了vbDirectory属性。 您可能不需要包含此参数作为Dir()函数的默认行为是查找没有属性的文件。

Answer 3

您可以使用Scripting.FileSystemObject集合对文件夹中的所有文件执行任何操作，如下所示：

 dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject") dim oFolder : Set oFolder = oFso.GetFolder("folderpath") For Each oFile in oFolder.Files ' do whatever you like in here for each file... Next