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

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 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

Answer 2

尝试：

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 个文件，宏将不包含它们。如果您想查看更多内容，可以删除条件“And c