时间戳

首页 > 解决方案 > VBA将多个工作簿中的单元格复制到另一个工作表中

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

问题描述

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

标签： excelvbacopyworksheet

解决方案

复制单元格

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

推荐阅读