Вставка VBA в другую рабочую книгу, другую рабочую таблицу

Question

У меня сложная проблема с копированием и вставкой. У меня есть книга Excel 2007 под названием «Сводка» с двумя листами (лист 1 и лист 2). У меня есть список имен книг Excel, которые находятся в указанной папке на моем жестком диске, напечатанный в столбце А на листе 1. Я пытаюсь открыть каждую из этих книг, скопировать определенные ячейки в каждую из этих книг и вставить их в мой Сводная рабочая тетрадь, в листе ДВА. У меня их отлично получается на листе 1, но я не могу скопировать их на лист 2. Любая помощь будет принята с благодарностью!

Спасибо,

Jonathan

Вот мой код:

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