Question

我想遍历文件夹中的所有Excel文件，以便对每个文件执行某些操作（所有文件都具有相同的布局，并且只有Sheet1上的数据）。

到目前为止，我有以下代码，它给出了特定文件夹中的Excel文件列表。我无法弄清楚自己是如何从每个文件中复制数据的 - 特别是我需要从每个文件中复制A10：E50范围内的数据，然后将其粘贴到我当前文件的页面上（全部低于对方）。

有人可以帮我这个吗？

我目前的代码：

Sub FindFiles()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add

    Set objFolder = objFSO.GetFolder("C:\Users\mo\Desktop\Test-Import\")
    'ws.Cells(1, 1).Value = "The folder " & objFolder.Name & " contains the following Excel files:"

    For Each objFile In objFolder.Files
        ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
    Next

    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing
End Sub

非常感谢您的帮助，麦克

Answer 1

尝试：

Sub FindFiles()
Dim objFolder As String, objFile As String, r As Integer, c As Integer    'r=row, c=column
Dim ws As Worksheet

Set ws = Worksheets.Add
objFolder = "C:\Users\mo\Desktop\Test-Import\"
objFile = Dir(objFolder)
r = 10: c = 1

While objFile <> vbNullString And c < 6
    ws.Cells(r, c).Value = objFile
    r = r + 1
    If r = 51 Then
        r = 10
        c = c + 1
    End If
    objFile = Dir
Wend

End Sub

请注意，这将仅列出适合A10的文件数：E50（200个文件）。如果您有超过200个文件，宏将不包含它们。你可以删除条件＆＃34;并且c＆lt; 6＆＃34;如果你想看到更多，或编辑＆＃34; r＆＃34;值列出更多行的文件

Answer 2

尝试下面的内容......

Sub FindFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As File
Dim ws As Worksheet
Dim srWS As Worksheet
Dim wb As Workbook
Dim path As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
path = "  " 'Enter your path here
Set objFolder = objFSO.GetFolder(path)
'ws.Cells(1, 1).Value = "The folder " & objFolder.Name & " contains the following Excel files:"

Set ws = Worksheets.Add

For Each objFile In objFolder.Files
    rowCount = ws.UsedRange.Rows.Count
    If (objFile.Type = "Microsoft Excel Worksheet" Or objFile.Type = "Microsoft Excel Macro-Enabled Worksheet") Then
     Set wb = Application.Workbooks.Open(path & objFile.Name)
     Set srWS = wb.Sheets(1)
     srWS.Range("A10:E50").Copy
     ws.Activate
     If rowCount = 1 Then
        ws.Cells(1, 1).Value = objFile.Name
        ws.Cells(rowCount + 1, 1).Select
     Else
        ws.Cells(rowCount + 1, 1).Value = objFile.Name
        ws.Cells(rowCount + 2, 1).Select
     End If
     ActiveSheet.Paste
     Application.DisplayAlerts = False
     wb.Close
    End If

Next
Application.DisplayAlerts = True
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub

Excel / VBA：如何从多个Excel文件复制数据

2 个答案: