VBA将多个工作簿中的单元格复制到另一个工作表中答案

【问题标题】：VBA to copy a cell from multiple workbooks into another sheetVBA将多个工作簿中的单元格复制到另一个工作表中
【发布时间】：2021-03-14 21:19:12
【问题描述】：

我在同一个文件夹中有 10 个 excel 文件。我正在尝试将活动工作表的单元格 A2 从这 10 个 excel 文件中的每一个复制到另一个 excel 文件的工作表中 - 我们称之为 EX2 文件。 EX2 有一个工作表名称 Product，我想在此工作表的 A 列末尾添加新的 10 个值。

下面是我的代码。试了好几次都没成功

    Dim Path As String
    Dim Filename As String
    Dim WB As Workbook
    Dim RowCnt As Long
    
    Path = "C:\Users\***\Documents\Folder 10\"
    Filename = Dir(Path & "*.xlsm*")
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Do While Filename <> ""
        Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
        For Each ActiveSheet In WB.Sheets
            ActiveSheet.Cells(2, 1).Copy
            RowCnt = ThisWorkbook.Worksheets("Product").Range("A1").End(xlDown).Row + 1
            ThisWorkbook.Worksheets("Product").Range("A" & RowCnt).PasteSpecial xlPasteValues
        Next ActiveSheet
        WB.Close
        Filename = Dir()
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

【问题讨论】：

标签： excel vba copy worksheet

【解决方案1】：

复制单元格

Option Explicit

Sub copyCell()
    
    Const FolderPath = "C:\Users\***\Documents\Folder 10\"
    
    Dim Filename As String: Filename = Dir(FolderPath & "*.xlsm")
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Product")
    Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
    
    Application.ScreenUpdating = False
    Do While Filename <> ""
        Set dCell = dCell.Offset(1)
        With Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
            dCell.Value = .ActiveSheet.Range("A2").Value
            .Close False
        End With
        Filename = Dir()
    Loop
    Application.ScreenUpdating = True

End Sub

【讨论】：