Collage VBA dans un autre classeur, feuille de travail différente

Question

J'ai un problème de copie et de collage difficile. J'ai un classeur Excel 2007, appelé Résumé, avec deux feuilles (feuille 1 et feuille 2). J'ai une liste des noms de classeurs Excel qui se trouvent dans le dossier donné sur mon disque dur tapé dans la colonne A sur la feuille 1. J'essaie d'ouvrir chacun de ces classeurs, copier des cellules spécifiques dans chacun de ces classeurs, et les coller dans mon Cahier de travail sommaire, dans la feuille DEUX. Je les ai parfaitement sur la feuille 1, mais je n'arrive pas à les copier sur la feuille 2. Toute aide serait grandement appréciée!

Merci,

Jonathan

Voici mon 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

Gardez une trace de vos classeurs.

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