VBA循环访问文件夹中的文件并将变量范围复制/粘贴到主文件

Question

我一直在寻找一段时间，试图找到解决方案，我可以找到类似的解决方案，但即使进行调整和修改，我也无法获得任何解决方案。

我有一个名为"Master.xlsb"的主工作簿，其中有一张名为"摘要"的工作表。我在一个名为"电子邮件附件"的文件夹中有 189 个文件的列表。

每个单独的文件都有不同数量的行，所以我想遍历所有文件并从范围"B7：B"和LastRow"复制，并将包含"Master.xlsb"数据的最后一行下方粘贴数据（随着数据的粘贴，数据会增加）。

另外，我希望 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:ExamplePath"
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 的一段不错的代码。 用于循环浏览文件夹中的文件使用 VBA 循环浏览文件夹中的文件？

重用他/她的代码，我会做这样的事情：

选项显式

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:ExamplePath"
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