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

Question

我在同一个文件夹中有 10 个 excel 个文件。我正在尝试将这 10 个 excel 文件中的每个文件中的活动作品 sheet 的单元格 A2 复制到另一个 excel 文件的 sheet - 让我们称之为 EX2 文件。 EX2 有一个 sheet 名称的产品，我想在这个 sheet 的 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

Answer 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

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

VBA to copy a cell from multiple workbooks into another sheet

excel

vba

copy

worksheet

复制单元格