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

Question

I have a tricky copy and paste problem. I have an excel 2007 workbook, called Summary, with two sheets in it (sheet 1 and sheet 2). I have a list of the names of excel workbooks that reside given folder on my hard drive typed into Column A on Sheet 1. I am trying to open each of those workbooks, copy specific cells in each of those workbooks, and paste them into my Summary workbook, in sheet TWO. I've got them going perfectly onto Sheet 1, but can't seem to copy them to Sheet 2. Any help would be greatly appreciated!

Thank you,

Jonathan

Here is my code:

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

Keep track of your workbooks.

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