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

问题描述：

我有一个棘手的复制和粘贴问题。我有一个名为Summary的2007年工作手册，里面有两张纸（表1和表2）。我有一个excel工作簿的名称列表，这些工作簿位于我的硬盘驱动器上的给定文件夹中，并输入到工作表1的列A中。我试图打开这些工作簿中的每一个，将这些工作簿中的特定单元格复制并粘贴到我的摘要工作手册，见第二页。我已经将它们完美地放在Sheet 1上，但似乎无法将它们复制到Sheet 2上。任何帮助都将不胜感激！VBA粘贴到不同的工作簿，不同的工作表

谢谢

乔纳森

这里是我的代码：

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

答

跟踪您的工作簿。

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

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

相关推荐