複数のExcelファイルを1枚にまとめるマクロ
複数のExcelファイルの内容を1枚のシートにまとめるには、コピー＆ペーストを繰り返せばよいのですが、数が多くなると面倒です。
マクロで実行する方法を考えました。
あるフォルダに保存されている複数のExcelファイルとそのシートをすべて取得し、別の1枚のシートにまとめます。
ただし制限があります。
シートのレイアウトやサイズがすべて同じならばコピー＆ペーストでよいのですが、そうとは限らないので、範囲をあらかじめ決めて、その範囲のセルの内容をテキスト形式で取得します。
つまり書式は無視されます。
また1枚のシートにまとめるときに左端にファイル名とシート名をセットします。
無駄な行を削除するために並び替えたりしてもすぐに復元できます。
サンプルは前半と後半に分かれます。
Excelファイルには「matome」というシートを作っておきます。
前半部分
宣言部分と実行部分になります。
まず宣言部分(「Const」がある行)に、まとめのシート名と、取得する列と行の数をセットします。多めにセットしておけば取りこぼしはないですが時間がかかります。
次にマクロ「シートにまとめる」を実行するとフォルダを選択するダイアログが出ます。
そして、後半部分の作業を連続して行います。
Const numrow = 50
Const numcol = 20
Dim gyo As Long
Sub シートにまとめる()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
myfolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
fn = Dir(myfolder & "\*.xls", vbNormal)
gyo = 1
Do Until fn = ""
Call getfromfile(fn)
fn = Dir
Loop
Sheets(snmatome).Select
End Sub
後半部分
前半部分のコードと同じモジュールに貼り付けます。
前半部分で指定したフォルダの中のExcelファイルを開き、セルの内容を配列変数に取り込みます。
そして、まとめシートに戻りファイル名とシート名とセルの内容を貼り付けます。
すべてのシートに対し、これを行います。
Dim arrs(1000, 1000)
myfn = ThisWorkbook.Name
Workbooks.Open Filename:=fn
For Each wb In Worksheets
sn = wb.Name
For x = 1 To numrow
For y = 1 To numcol
arrs(x, y) = wb.Cells(x, y)
Next y
Next x
For x = 1 To numrow
Workbooks(myfn).Sheets(snmatome).Cells(gyo + x - 1, 1) = fn
Workbooks(myfn).Sheets(snmatome).Cells(gyo + x - 1, 2) = sn
For y = 1 To numcol
Workbooks(myfn).Sheets(snmatome).Cells(gyo + x - 1, 3 + y - 1) = arrs(x, y)
Next y
Next x
gyo = gyo + numrow
Next
Workbooks(fn).Close
End Function
[ 2011年7月6日 | カテゴリー: Excel | タグ: VBA , シート , 複数 ]
« Wordで1ページずつPDFで保存するマクロ | 線形探索と二分探索をVBAで »
コメントを残す