VBA, вставляемый в другую книгу, другой рабочий лист

Question

У меня сложная проблема с копией и вставкой. У меня есть книга excel 2007, называемая Summary, с двумя листами в ней (лист 1 и лист 2). У меня есть список имен книг excel, которые находятся на данной папке на моем жестком диске, напечатанном в столбце A на листе 1. Я пытаюсь открыть каждую из этих книг, скопировать определенные ячейки в каждую из этих книг и вставить их в свой Сводная книга, на листе ДВА. Я получил их отлично на Лист 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