Question

我想为文件夹中的每个工作簿文件执行此功能。此脚本正在解析单个工作簿中的数据。我想为＆＃34; attach＆＃34;中的每个工作簿执行相同的任务。夹。这可以通过循环完成吗？

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

如果您要打开Excel工作簿，可以使用Dir()功能查找文件。（MSDN for the VB version, but it works the same in VBA as far as I can tell）这个小小的代码片段会显示我C:\目录中的文件。

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

只需修改你的函数以接受excel文件的路径作为参数，这应该可以解决这个问题。

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

Answer 2

您可以使用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

Answer 3

基本上你只需要这样做：

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

对文件夹中的所有文件执行功能

3 个答案: