VBA粘贴到不同的工作簿，不同的工作表

Question

我有一个棘手的复制和粘贴问题。我有一个名为“摘要”的 Excel 2007 工作簿，其中有两张表（表 1 和表 2）。我有一个 Excel 工作簿的名称列表，该列表位于硬盘驱动器上的给定文件夹中，输入到工作表 1 的 A 列中。我尝试打开每个工作簿，复制每个工作簿中的特定单元格，然后将它们粘贴到我的工作簿中。摘要工作簿，第二张。我已将它们完美地复制到工作表 1 上，但似乎无法将它们复制到工作表 2 中。任何帮助将不胜感激！

谢谢

乔纳森

这是我的代码：

Sub CopyRoutine()
    Const SrcDir As String = "C:\filepath\"
    Dim SrcRg As Range
    Dim FileNameCell As Range
    Dim Counter As Integer
    Application.ScreenUpdating = False
    'Selecting the list of workbook names
    Set SrcRg = Range(Range("A2"), Range("A3").End(xlDown))
    On Error GoTo SomethingWrong
    For Each FileNameCell In SrcRg
        Counter = Counter + 1
        Application.StatusBar = "Doing workbook " & Counter & " of " & SrcRg.Cells.Count
        'Copying the selected cells
        Workbooks.Open SrcDir & FileNameCell.Value
        Sheets("Sheet1").Visible = True
        Sheets("Sheet1").Select
        Range("'Sheet1'!J4:K4").Copy
        Sheets("Sheet2").Select
        'Pasting the selected cells - but i cannot seem to move to sheet 2!
        FileNameCell.Offset(0, 5).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False 'Clear Clipboard
        ActiveWorkbook.Close False
    Next
    Application.StatusBar = False
    Exit Sub
SomethingWrong:
    MsgBox "Could not process " & FileNameCell.Value
End Sub

Answer 1

跟踪您的工作簿。

Sub CopyRoutine()
    Const SrcDir As String = "C:\filepath\"
    Dim SrcRg As Range
    Dim FileNameCell As Range
    Dim Counter As Integer
    Dim SummaryWorkbook As Workbook       'added
    Dim SourceDataWorkbook As Workbook    'added
    Set SummaryWorkbook = ActiveWorkbook  'added
    Application.ScreenUpdating = False
    'Selecting the list of workbook names
    Set SrcRg = Range(Range("A2"), Range("A3").End(xlDown))
    On Error GoTo SomethingWrong
    For Each FileNameCell In SrcRg
        Counter = Counter + 1
        Application.StatusBar = "Doing workbook " & Counter & " of " & SrcRg.Cells.Count
        'Copying the selected cells
        Set SourceDataWorkbook = Workbooks.Open SrcDir & FileNameCell.Value
        Sheets("Sheet1").Visible = True
        Sheets("Sheet1").Select
        Range("'Sheet1'!J4:K4").Copy
        SummaryWorkbook.Sheets("Sheet2").Select  'goto correct workbook!
        'Pasting the selected cells - but i cannot seem to move to sheet 2!
        FileNameCell.Offset(0, 5).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False 'Clear Clipboard
        SourceDataWorkbook.Close False   
    Next
    Application.StatusBar = False
    Exit Sub
SomethingWrong:
    MsgBox "Could not process " & FileNameCell.Value
End Sub