为文件夹中的所有文件执行Do函数

Question

我想对文件夹中的每个工作簿文件执行此功能。此脚本是从单个工作簿解析数据。我想为“附加”文件夹中的每个工作簿预先形成相同的任务。这能用一个循环来完成吗？

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:\目录中找到的文件。

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

只需修改您的函数以接受excel文件的路径作为参数，这将为您带来好处。

注意，我在本例中使用了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