VBA 循环遍历文件夹中的文件和 copy/paste 可变范围到主文件

Question

我已经搜索了一段时间，现在试图找到一个解决方案，我可以找到类似的解决方案，但即使进行了调整和修改，我也无法正常工作。

我有一个名为 'Master.xlsb' 的主工作簿，其中有 1 个 sheet 名为 'Summary'。我在一个名为 'EmailAttachments'.

的文件夹中列出了 189 个文件

每个单独的文件都有不同的行数，所以我想遍历所有文件并从范围“"B7:B" & LastRow”复制并将数据粘贴到包含 [=29= 中的数据的最后一行下方]（随着数据的粘贴而增加）。

此外，我希望 A 列中的文件名从“"A7"”开始，这样我就知道数据来自哪个文件。

提前致谢。

编辑：

我设法让代码在下面工作：

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub

Answer 1

在这里我发现了用户benmichae2 的一个不错的代码。用于遍历文件夹中的文件 Loop through files in a folder using VBA?

重用 his/her 代码我会这样做：

选项显式

Sub LoopThroughFiles()

Dim firstEmptyRow As Long
Dim attachmentFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook
Dim copyRngToArray As Variant

'# Define folder with attachments and set file extension
attachmentFolder = "C:\temp"
filenameCriteria = "xlsx"

'set
StrFile = Dir(attachmentFolder & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
    Set attachmentWorkBook = Workbooks.Open(StrFile)

    With attachmentWorkBook.Worksheets(1)
        '#Copy the first column to array starting from "A7" to End of column
         copyRngToArray = .Range("A7:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    '#Thisworkbook is the file where this code is in actually your Master.xlsb file
    With ThisWorkbook.Worksheets(1)
        '#firsEmptyRow returns the first empty row in column B
        firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        '#paste file name to Column A
        .Range("A" & firstEmptyRow) = StrFile
        '#paste data in column B
        .Range("B" & firstEmptyRow).Resize(UBound(copyRngToArray)) = copyRngToArray
    End With

    Set attachmentWorkBook = Nothing
    StrFile = Dir
Loop

End Sub

将此代码粘贴到一个模块中并检查一些示例 excel 文件

Answer 2

以下代码对我有用（更改示例路径）：

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub

VBA 循环遍历文件夹中的文件和 copy/paste 可变范围到主文件

VBA Loop through files in folder and copy/paste variable range to master file

excel

vba

excel-2016