ディレクトリ内にある複数のエクセルファイルデータを抽出したいです。

ディレクトリ内にある複数のエクセルファイルデータを抽出したいです。
ディレクトリ内にある複数のエクセルファイルがあります。
各ファイルのSheet1の列Aと列Bと列Cと列Gと列Hのデータをインポートして１つのエクセルファイルにエクスポートしたいと考えています。
こういうことをマクロで実現することはできますでしょうか。

No.1 回答者： o_chi_chi 回答日時： 2010/11/02 09:57

まずマクロの記録で１つのファイルを対象に

上記操作のマクロを作成してみましょう。

その後複数ファイルが対象になるように
改良していくのがよいかと思います。

No.2 回答者： rukuku 回答日時： 2010/11/02 23:54

こんばんは

＞こういうことをマクロで実現することはできますでしょうか

できます。
こう回答しますと「サンプルをください」と言いたい気持ちにはなるでしょうが、
実際に使うプログラムとなるとこのサイトでは限界があると思います。

MEGUMI19800214さんが勉強されるか、出来る人に依頼するかしかないと思います。

＞ディレクトリ内にある複数のエクセルファイルデータ
同じフォルダ内にあるエクセルファイルをすべて対象にするならば
Dir関数が利用できます。

Sub sumple()
　Dim XlFile As String
　
　ThisWorkbook.Activate
　Worksheets(1).Select
　Cells.Clear
　
　XlFile = Dir("*.xls")
　Do While XlFile <> ""
　　If XlFile <> ThisWorkbook.Name Then
　　　'ここに、対象のエクセルファイルを開きコピーするプログラムを記述
　　End If
　　XlFile = Dir()

　Loop
　
End Sub

コピー先のセルの最終行を取得するには
[A65536].end(xlup)
が便利です（A列は必ず値が入っており、空欄はないと想定しています）。

マクロからエクセルファイルを開いたり閉じた出来ますが、対象のファイルが既に開いていたらどうする？などの処理も必要です。

この回答へのお礼

rukukuさま

分かりやすいご連絡を頂きまして本当にありがとうございます！
私はマクロについては本当にかじった程度なのですが、
マクロの記録を使ってみて、rukukuさまのアドバイスを参考に下記のマクロを作ってみました。
でも、うまく動きませんでした。
[A65536].end(xlup)も試してみたのですが、A,B,C,G,H列で使用する場合、

[A65536].end(xlup)
[B65536].end(xlup)
[C65536].end(xlup)
[G65536].end(xlup)
[H65536].end(xlup)
とするのでしょうか？
お忙しいところ大変恐れ入りますがもしお時間ありあしたら返信を頂ければ助かります。
宜しくお願い致します。

Sub 今月の整理()
Dim XlFile As String

ThisWorkbook.Activate
Worksheets(1).Select
Cells.Clear

XlFile = Dir("*.xls")
Do While XlFile <> ""
If XlFile <> ThisWorkbook.Name Then
Range("A2:C8,G2:H8").Select
Range("G2").Activate
Selection.Copy
ActiveSheet.Paste
Range("A9").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
End If
XlFile = Dir()
Loop
End Sub

お礼日時：2010/11/03 09:40

No.3 回答者： rukuku 回答日時： 2010/11/03 21:52

＞でも、うまく動きませんでした。

私のサンプルに一部間違いがありました。申し訳ありません。
また、MEGUMI19800214さんが作成した部分にも不足があります。
それらを含めて、回答します。

まず、私が間違えた点です。
最初のDir関数は、以下の様にフォルダ名を指定する必要があります。
　XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
ThisWorkbook.Pathでマクロのあるブックのフォルダ名が取得できます
xlsの後ろに「？」を付けたのは、バージョン2007以降で拡張子がxlsxになったことへの対応です。


ExcelマクロからExcelファイルを開くには
　Workbooks.Open ファイル名
を使います。このとき、新しく開いたブックが「アクティブ」になります。
Worksheets(1)以外が選択されている場合に備えて、ブックを開いたらWorksheets(1)を選択します。
また、２つのブックの間でコピーするので、どちらのブックを対象にしているのかを指示します。

>[A65536].end(xlup)も試してみたのですが、A,B,C,G,H列で使用する場合、
　[A65536:H65536].End(xlUp)
でA～H列の最終の行が分かります。

以下がサンプルです。

Sub sumple()
　Dim XlFile As String
　Dim MotoDataLastRow As Long
　Dim CopySakiLastRow As Long
　
　ThisWorkbook.Activate
　Worksheets(1).Select
　Cells.Clear
　
　XlFile = Dir(ThisWorkbook.Path & "\*.xls?")
　Do While XlFile <> ""
　　If XlFile <> ThisWorkbook.Name Then
　　　Workbooks.Open ThisWorkbook.Path & "\" & XlFile, ReadOnly:=True
　　　Worksheets(1).Select
　　　MotoDataLastRow = Workbooks(XlFile).Worksheets(1).[A65536:H65536].End(xlUp).Row '元データファイルの最終行を取得
　　　CopySakiLastRow = ThisWorkbook.Worksheets(1).[A65536:E65536].End(xlUp).Row 'インポート先の最終行を取得
　　　Range([A1], Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　　　Range([G1], Cells(MotoDataLastRow, "H")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
　　　Workbooks(XlFile).Close False
　　End If
　　XlFile = Dir()
　Loop
　
End Sub

この回答へのお礼

本当にありがとうございます！
大成功でした。

恐縮なのですが、コピー範囲を指定するときに
　2行目以降の列でデータがるものをすべて
とする場合、
[A65536:H65536]
に何を付け足せば上記の命令になるのでしょうか？

めぐ

お礼日時：2010/11/04 09:19

No.4 ベストアンサー 回答者： rukuku 回答日時： 2010/11/04 12:37

>2行目以降の列でデータがるものをすべて

　Range([A1], Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　Range([G1], Cells(MotoDataLastRow, "H")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
を以下のように変更します
　Range([A2], Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　Range([G2], Cells(MotoDataLastRow, "H")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")

ただし、２行目以降に全くデータがないときには１行目をコピーしてしまいます。
そこで、IF文を使って２行目以降にデータがあるときだけコピーするようにします。
　If MotoDataLastRow > 1 Then
　　Range([A2], Cells(MotoDataLastRow, "C")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "A")
　　Range([G2], Cells(MotoDataLastRow, "H")).Copy ThisWorkbook.Worksheets(1).Cells(CopySakiLastRow + 1, "D")
　End If

この回答へのお礼

本当に何から何までありがとざいました。
頂いた内容でまったく問題なくできました。
親切にご指導下さりまして本当にありがとうございました。

お礼日時：2010/11/04 16:47