ファイルをまとめたい

Question

エクセル初心者です。
デスクトップ上の一つのフォルダの中に同じようなファイルが１００位あるのですが、そのファイル、１つになりませんか？
請求書０１～請求書９９（その時によっていろいろです。）という名前のブックをひとまとめにしてシート名が０１～９９みたいにしたいんです。（一番前には目次シートで）
ネットで同じような質問をさがしてやってみたのですがうまくいきません。

どなたか教えてください。お願いします。

fujillin · Accepted Answer

ANo3です

テスト中に入れ替えたのを、戻し忘れていました。
中ほどの
Set tb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & fName, UpdateLinks:=0, ReadOnly:=False)

の部分は、以下が正です。すみません。

Set tb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & fName, UpdateLinks:=0, ReadOnly:=True)

fujillin · Answer

こんにちは

100個のファイルがあると、外部参照していたり、保護がかけられていたり、open時に実行されるマクロが混じっていたり…などなどの可能性があるので、ファイルオープン時のチェックをいろいろ行わないと、各種のメッセージやエラーが出る可能性がありますが、とりあえずそのあたりは無視して雰囲気のみのコードです。
（特に何もしていないファイルだけが対象なら動作するはずです）

ANo1様が紹介なさっているようなソフトを利用する方が、検討と検証を重ねているはずなので、確実性は高いはずと想像します。

以下、ご参考まで。
※ マクロのあるブックに各ブックのシートをまとめます。
　マクロのあるブックは書き換えられるため、既存のデータは全て消されます。
　（既存のシートは無条件で削除されます）
※ 対象は、マクロのあるブックと同じフォルダ内にあるブック（複数）です。
※ 各ブック内のシート（複数）を順にコピーしますが、シート名が重複する可能性が高いので、新しいシート名は『ブック名_シート名』に変えています。
※ 目次はそのままの順で、A列にブック名、B列にシート名の形式で作成します。
※ 多少はエラーや警告が出にくいようにはしていますが、基本的にエラー処理等は一切行っていませんので、ご注意ください。
　単純コピーを行っていますので、壊れたブックをコピーすると、ペースト先のブックも壊れる場合があります。
※ ブック数が多いとそれなりに時間がかかりますので、テストは少数ファイルで行ってみてください。
（画面のチラつきを消したければ、コメントアウトしてある
　'Application.ScreenUpdating = False/True
の行を有効にすることで、少しは速度向上にもなります）

Sub Sample()

Dim security, reg As Object
Dim wb As Workbook, sh As Worksheet, rng As Range
Dim tb As Workbook, ts As Worksheet, ns As Worksheet
Dim fName As String, fNstr As String

Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "\.xls[^\.]*$"

'目次シートを作成（他は削除）
Set wb = ThisWorkbook
wb.Worksheets.Add Before:=wb.Worksheets(1)
Application.DisplayAlerts = False
Do While wb.Worksheets.Count > 1
　wb.Worksheets(2).Delete
Loop
Application.DisplayAlerts = True

Set sh = wb.Worksheets(1)
Set rng = sh.Range("A2:B2")
sh.Name = "目次"
rng.ColumnWidth = 15
rng.Offset(-1) = Array("ファイル名", "シート名")

'Stop(目次シートのみの状態）

'Application.ScreenUpdating = False
security = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable

'フォルダ内の.xls*ファイルの内容を順にコピー
fName = Dir(wb.Path & "\*.xls*")
Do While fName <> ""
　If fName <> wb.Name Then
　　Set tb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & fName, UpdateLinks:=0, ReadOnly:=False)
　　rng.Cells(1, 1).Value = fName
　　fNstr = reg.Replace(fName, "") & "_"
　　
　 'ブック内の各シートを順にコピー
　　For Each ts In tb.Worksheets

'　　　↓ではブック間だとうまく動作しない？
'　　　ts.Copy After:=wb.Worksheets(wb.Worksheets.Count)
'　　　やむを得ずセルのコピーで対応
　　　wb.Worksheets.Add After:=wb.Worksheets(wb.Worksheets.Count)
　　　Set ns = wb.Worksheets(wb.Worksheets.Count)
　　　ns.Name = fNstr & ts.Name
　　　ts.Cells.Copy Destination:=ns.Cells

　　　rng.Cells(1, 2).Value = ts.Name
　　　sh.Hyperlinks.Add Anchor:=rng.Cells(1, 2), Address:="", SubAddress:=ns.Name & "!A1"
　　　Set rng = rng.Offset(1)
　　Next ts
　　
　　tb.Close SaveChanges:=False
　End If
　fName = Dir
Loop

Application.AutomationSecurity = security
sh.Activate
'Application.ScreenUpdating = True

End Sub

ryo_ky · Answer

VBAでやりたいなら次のようなステップを踏んではどうでしょうか？
① フォルダ内にあるxls（xlsx）データ名とデータ数を取得する．
② シートを作成する．
③ ある取得したデータ名と同一名のxlsファイルを開く．
④ アクティブシートを全選択し，コピーする．
⑤ ②で作成したシートに貼りつけする．
⑥ ②で作成したシート名を取得したデータ名に変更する．
⑦ ある取得したデータ名と同一名のxlsファイルを閉じる．
⑧ 繰り返し演算子（適当な引数）に1を加算する．
⑩ ②～⑧を繰り返し（Do～Loop），繰り返し演算子の数が①で取得したデータ数を超えた時に繰り返しを終了する．
データを開く順番は名前順で取得すれば良いと思います．

時間が無いので，コード記述まではできませんが，ご参考までに

DEBU-NEKOMARU · Answer

方法↓
https://support.microsoft.com/ja-jp/help/881127
これを　延々と　100回繰り返す

複数のファイルをまとめる　フリーソフト
http://www.vector.co.jp/soft/winnt/business/se401803.html

しかし、ひとつのファイルに　シートが　101も存在すると
それを探すのにも　手間がかかり　現実的ではないと思います。

ファイルをまとめたい

ANo3です

こんにちは

VBAでやりたいなら次のようなステップを踏んではどうでしょうか？

方法↓

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング