複数のエクセルファイルの指定範囲をコピーするには？

質問

複数のエクセルファイルの指定したセル範囲を、一括して他のエクセルファイルにコピーするフリーソフトがあれば教えてください。
例えばＡ，Ｂ，Ｃという名前のエクセルファイルを、それぞれ１行目だけを抽出して（指定したセル範囲）、Ｄという新規のエクセルファイルに並べてコピーするといった具合です。

回答No.3

pascal3141 · ベストアンサー

自作のＶＢＡプログラムを乗せますので使ってみてください。
（１）A,B,C等のエクセルファイルは、すべて同じ名前のシート（今は、dataシートとします）に必要なデータが同じ形で入っていること。
（２）集計用エクセルファイル名は、D.xlsという名前で、そこにsearchシートとworkシートを作っておきます。
（３）A,B,C,Dファイルはすべて同じフォルダに入れておきます。ここには余分なエクセルファイルは入れないようにします。
（４）あとは、D.xlsを立ち上げて、マクロから、Filesearchを実行。
searchシートにフォルダ内のすべてのファイル名と場所が一覧で出ます。またworkシートには各A,B,Cの必要な範囲のデータが、上から順に追加はりつけされます。
（５）各範囲、名前の変更は、あとのコードの「各値初期設定」の所を変更します。
（６）注意点：これは自分の仕事（アンケート集計用）に作りましたので、各ファイルの１行目は項目タイトルなっています。そのため、１行目はコピーしません。１行目からコピーしたい場合は、'各シートからデータをMainに追加貼り付け　の場所の、cells(i+1,j) cells(Dline+1,j)をcells(i,j) cells(Dline,j)になおせばいけるはずです。

以下のコードを貼り付けしましょう。GoodLuck!

Sub FileSearch(): 'ファイル検索

Dim sfolda As String
Dim SName As String
Dim i, j, k, n As Integer
Dim ww As String
Dim L, S As Integer
Dim ws As Object

Dim DName As String
Dim KName As String
Dim MainName As String
Dim PP, FF As String
Dim MaxG, DKoumoku, DLine As Integer
Dim MaxFileSu As Integer

Application.ScreenUpdating = False

'各値初期設定=======================================================
DName = "work": '集計シート名
　KName = "data": '合成処理をする各ファイルのシートの名前
MainName = "D.xls": '集計用エクセルファイル名
MaxFileSu = 50: '合成処理をするファイルの最大数
DKoumoku = 13: '合成処理をする横方向の項目数
MaxG = 15: '合成処理をする各ファイルのデータの行数
'====================================================================

DLine = 1: 'データ入力行数カウント

'現在のフォルダのパスを設定
sfolda = ThisWorkbook.Path

'ファイル名を入れるシートをセットおよび初期化
Set ws = Workbooks(MainName).Worksheets("search")
ws.Range("B1").ClearContents
ws.Range("A4:B200").ClearContents
ws.Cells(1, 2).Value = sfolda

'各ファイル名を検索しsearchシートに登録
SName = "*.xls"
n = 1

With Application.FileSearch
.LookIn = sfolda
.Filename = SName
rs1 = .Execute
If rs1 = 0 Then Exit Sub
For Each nm In .FoundFiles
ww = nm
S = 1
While S > 0
S = InStr(1, ww, "\", 1)
L = Len(ww)
ww = Right(ww, L - S)
Wend
If ww <> MainName Then
ws.Cells(n + 3, 1).Value = n: '１列目に番号セット
ws.Cells(n + 3, 2).Value = ww: '２列目にファイル名セット
n = n + 1
End If
Next nm
End With

'======================================================================
'合成処理

For n = 1 To MaxFileSu

'ファイル名をセット
PP = ws.Cells(1, 2).Value
If ws.Cells(n + 3, 2).Value = "" Then Exit For
FF = ws.Cells(n + 3, 2).Value
PP = PP & "\" & FF

'ファイルオープン
Workbooks.Open (PP)

'各シートからデータをMainに追加貼り付け
For i = 1 To MaxG
For j = 1 To DKoumoku
aa = Workbooks(FF).Worksheets(KName).Cells(i + 1, j).Value
Workbooks(MainName).Worksheets(DName).Cells(DLine + 1, j).Value = aa
Next j
DLine = DLine + 1
Next i

'ファイルクローズ
Workbooks(FF).Close
Next n

End Sub

お礼

ありがとうございました。もう少しマクロを勉強してみます

補足

回答ありがとうございます。マクロを作ったことが無いので、恐縮ですが、複数のファイルの抽出したいデータ範囲をG3のみにしたい場合は、どこを変えればよいでしょうか？また上から並べて貼り付ける場合、行を隙間無く埋めたいのですが、どうしたらよいでしょうか？

回答No.2

xls88

>一応上記マクロをコピーして実行しましたがうまくいきませんでした。
ということですが、そのまま実行されたのですか？
実際に合わせて、ブック名、シート名を書き換える必要はないのですか？
対象ブックを全て開いた状態でマクロを実行してください。
うまくいかなかった内容の説明はできますか？
エラーは出なかったのですか？
エラーが出たなら、その内容と発生行を教えてください。
メッセージボックスの「デバッグ」ボタンを押せばエラー発生行にジャンプします。

回答No.1

xls88

マクロでは駄目ですか？

Sub test()
　　Dim dwbs As Object
　　Dim rng As Range
　　Dim wbn As Variant
　　Dim rwn As Long
　　Dim i As Integer

　　wbn = Array("A.xls", "B.xls", "C.xls")
　　Set dwbs = Workbooks("D.xls").Worksheets("抽出")

　　For i = 0 To UBound(wbn)
　　　　With dwbs
　　　　　　rwn = .Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Row
　　　　　　Set rng = .Range(.Cells(rwn, "A"), .Cells(rwn, "E"))
　　　　End With
　　　　rng.Value = Workbooks(wbn(i)).Worksheets("Sheet1").Range("A1:E1").Value
　　Next i
End Sub

お礼

どうもありがとうございました。勉強不足です

補足

すみません。マクロは詳しくないもので、一応上記マクロをコピーして実行しましたがうまくいきませんでした。（私の知識不足です）
それと補足としてファイルを開かずに任意のファイルを選択して、その中で自分の抽出したいセル範囲を選択できて、それを新規エクセルファイルに並べてコピーしたいのですが・・・