[[20090824164500]]　『複数のExclファイルの特定行を別ファイルに順次コ』（RaRa）　ページの最後に飛ぶ

『複数のExclファイルの特定行を別ファイルに順次コピー』（RaRa）

同一フォルダ内に複数の同一形式のExcelファイルが入っています。
各Excelファイルには複数のシートがありますが、その中の「個人別集計結果」というシートの6行目を「まとめ.xls」の「部門別集計結果」というシートの7行目以降に順次コピーしていきたいと思います。

例えば、aaa.xls、bbb.xls、ccc.xlsの3つのExcelファイルがあり、それぞれ「個人別集計結果」というシートがあります。
まとめ.xlsの「部門別集計結果」のシートの
7行目にaaa.xlsの「個人別集計結果」の6行目を、
8行目にbbb.xlsの「個人別集計結果」の6行目を、
9行目にccc.xlsの「個人別集計結果」の6行目を、
コピーしたいのです。

実際にはコピー元のExcelファイルは300個程度あり、全て「まとめ.xls」と同一のフォルダ内に格納されています。
良い方法があればご教示ください。

Excel2003
WindowsXP

 とりあえず、単純に動かせるサンプルを載せてみます。
 詳しくはFileSystemObjectをネットで調べてみてください。
 その他のやり方としてはDir関数をループさせる方法もあります。

  Sub test()
  Dim lngRowCount As Long, wb As Object
  Application.ScreenUpdating = False
  lngRowCount = 7
  With CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    For Each wb In .GetFolder(ThisWorkbook.Path).Files
      If .GetExtensionName(wb.Path) = "xls" And _
        wb.Name <> ThisWorkbook.Name Then
        With Workbooks.Open(wb.Path)
          .Worksheets("個人別集計結果").Rows(6).Copy _
            ThisWorkbook.Worksheets("部門別集計結果").Rows(lngRowCount)
          If Err.Number = 0 Then lngRowCount = lngRowCount + 1
          .Close False
        End With
      End If
    Next wb
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
  End Sub

 （ｍｏｍｏ）

 以前に似た処理を書いたっけなぁと思い出したのでペッタリ。

[[20050210100639]]『複数のファイルを１つのファイルに集約』（香織）

 やろうとしている処理内容は違いますが、
同じ場所にあるxlsファイルを全て処理するって部分が同じ。
 >その他のやり方としてはDir関数をループさせる方法もあります。
の例として参考になれば。
（ご近所PG）

（RaRa）です。

（momo）さん＆（ご近所PG）さん、解決策のご提供ありがとうございました。
お礼が遅くなりすみません。

お二人のモジュールを参考に以下のようなモジュールを作成してみました。

Sub 複数のブックの6行目をある一つのブックの7行目以降に追記する()

    Dim strPath As String
    Dim strBookName As String
    Dim TargetBook As Workbook
    Dim OriginalSheet As Worksheet
    '指定した場所にあるxlsファイルについて処理
    strPath = ThisWorkbook.Path '自分自身と同じ場所とする
    strBookName = Dir(strPath & "\*.xls") 'ファイル名取得
    lngRowCount = 7
    '対象ファイルが存在する限り処理
    Do While strBookName <> ""
        If ThisWorkbook.Name <> strBookName Then '自分自身じゃないなら
            'そのブックを開く
            Set TargetBook = Workbooks.Open(strPath & "\" & strBookName)
            '開いたブックの全てのシートを処理
            Worksheets("個人集計結果").Rows(6).Copy
            ThisWorkbook.Worksheets("個人集計結果のまとめ").Rows(lngRowCount).PasteSpecial Paste:=xlValues
            lngRowCount = lngRowCount + 1
            TargetBook.Close
            Set TargetBook = Nothing
        End If
        strBookName = Dir '次のファイル
    Loop
    Exit Sub
End Sub

お蔭様で、これで何とか思うような処理ができたのですが、一つ問題が残っています。
Pasteの実行時に毎回（つまりブック数分）、
「クリップボードに大きな情報があります。…クリップボードに保存しますか？…」
とメッセージが出て、毎回「はい」をクリックしなければなりません。
このメッセージを省略する方法、あるいはこのような状況を回避する方法があったら教えてください。

よろしくお願いします。

 >ThisWorkbook.Worksheets("個人集計結果のまとめ").Rows(lngRowCount).PasteSpecial Paste:=xlValues
 の後に、
 Application.CutCopyMode = False
 を入れてみてください。
 （ｍｏｍｏ）

（RaRa）です。

（momo）さん、早速に解決策を授けてくださりありがとうございます。
お蔭様で思うようにできました。
大感謝です！

コメント返信：

[ 一覧(最新更新順) ]

[[20090824164500]] 『複数のExclファイルの特定行を別ファイルに順次コ』（RaRa） ページの最後に飛ぶ

[[20090824164500]]　『複数のExclファイルの特定行を別ファイルに順次コ』（RaRa）　ページの最後に飛ぶ