0

トリッキーなコピーと貼り付けの問題があります。概要と呼ばれる Excel 2007 ワークブックがあり、その中に 2 つのシート (シート 1 とシート 2) があります。シート 1 の列 A に入力された、ハード ドライブ上の特定のフォルダーに存在する Excel ワークブックの名前のリストがあります。これらの各ワークブックを開いて、それらの各ワークブックの特定のセルをコピーし、それらを自分のワークブックに貼り付けようとしています。シート 2 のサマリー ワークブック。それらをシート 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
4

1 に答える 1

0

ワークブックを追跡します。

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
于 2010-11-10T15:25:38.297 に答える