【Excel VBA】1つのファイルにまとめる方法

質問

1つのフォルダの中に複数のExcelファイルが保存されています。

seat1だけを1つに集めたExcelファイルを新規で作成したいです。
※シート1をどんどん追加させるイメージです。
※フォルダの中に入っているExcelファイル数は毎月変わります。

手順(1)フォルダに入っているExcelシートを開く
手順(2)sheet１を【シートの移動またはコピー】新規BOOKにコピー
手順(3)フォルダに入っているExcel分繰り返す。
手順(4)シート名を変更する。

どういう風にVBAコードを記入すればいいかわからないので教えていただきたいです。どうぞよろしくお願いいたします。

回答No.4

SI299792

済みません。前に説明した修正箇所は間違いです。
Pathにあなたの処理したいPath名を入れて下さい。
'
Option Explicit
'
Sub Macro1()
'
　　Const Path = "C:\Users\MA\Desktop\My Documents"
　　Dim FileName As String
　　Dim Sheet As Integer
'
　　FileName = Dir(Path & "\*.xls")
'
　　While FileName > ""
　　　　Sheet = Sheet + 1
　　　　If Sheet > Sheets.Count Then
　　　　　　Sheets.Add after:=Sheets(Sheet - 1)
　　　　End If
'
　　　　Workbooks.Open Path & "\" & FileName, ReadOnly:=True
　　　　Cells.Copy ThisWorkbook.Sheets(Sheet).[A1]
　　　　Application.CutCopyMode = False
　　　　ActiveWorkbook.Close False
　　　　On Error Resume Next
　　　　ThisWorkbook.Sheets(Sheet).Name = [A1]
　　　　On Error GoTo 0
　　　　FileName = Dir
　　Wend
End Sub

何でここは回答を消せないんだ。間違いを保存して何の意味がある。

回答No.3

SI299792

xls にするとxls を含む全て、が対象になります。（私も知らなかった）
その結果、xlsmも対象になり自分自身を開こうとして、エラーになる。これが原因だと思います。
　　FileName = Dir("C:\Users\MA\Desktop\My Documents\*.xls")
の様に直接フォルダ名を指定して下さい。
また、対象フォルダから、このマクロを入れたワークブックを別のフォルダに移動して下さい。（このフォルダに、このマクロを入れたワークブックを入れない）
今後、失敗した場合、どんなエラーメッセージが出て、何処で止まるのか、全く動かないのかなど、どのような状態になるのかも書いて下さい。

補足

SI299792 様

せっかく回答いただいておりましたのに
確認が遅くなり、お礼ができておらず申し訳ありませんでした…

PCが壊れてしまいログインがで来ませんでした…。

また教えていただいたようにしたのですが何度試してもファイルが見つからないというエラーになってしまいます。

何度も質問してしまい大変恐縮なのですが、お力をお貸しいただけないでしょうか。

▼エラー
実行時エラー１００４
申し訳ございません。ファイルが見つかりません。名前が変更されたか、移動や削除が行われた可能性があります。

▼以下構文です
Option Explicit
'
Sub Macro1()
'
　　Dim FileName As String
　　Dim Sheet As Integer
'
　　FileName = Dir("C:\Users\MA\Desktop\My Documents\*.xls")
'
　　While FileName > ""
　　　　Sheet = Sheet + 1
　　　　If Sheet > Sheets.Count Then
　　　　　　Sheets.Add after:=Sheets(Sheet - 1)
　　　　End If
'
　　　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, ReadOnly:=True
　　　　Cells.Copy ThisWorkbook.Sheets(Sheet).[A1]
　　　　Application.CutCopyMode = False
　　　　ActiveWorkbook.Close False
　　　　On Error Resume Next
　　　　ThisWorkbook.Sheets(Sheet).Name = [A1]
　　　　On Error GoTo 0
　　　　FileName = Dir
　　Wend
End Sub

回答No.2

SI299792

すみません。前プログラムはファイル名をシート名にしています。直しました。（全回答を消せないのは不便だ。回答がごちゃごちゃになる）
A1が空白、同じシートが存在するなどで、シート名をつけれない場合、名前をつけません。

このワークブックを保存したフォルダと同じフォルダを対象にしています。
xlsxを対象にしています。
'
Option Explicit
'
Sub Macro1()
'
　　Dim FileName As String
　　Dim Sheet As Integer
'
　　FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
'
　　While FileName > ""
　　　　Sheet = Sheet + 1
　　　　If Sheet > Sheets.Count Then
　　　　　　Sheets.Add after:=Sheets(Sheet - 1)
　　　　End If
'
　　　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, ReadOnly:=True
　　　　Cells.Copy ThisWorkbook.Sheets(Sheet).[A1]
　　　　Application.CutCopyMode = False
　　　　ActiveWorkbook.Close False
　　　　On Error Resume Next
　　　　ThisWorkbook.Sheets(Sheet).Name = [A1]
　　　　On Error GoTo 0
　　　　FileName = Dir
　　Wend
End Sub

補足

分かりやすい回答を記載いただきありがとうございました！

xlsxではなく、xlsの場合は
【FileName = Dir(ThisWorkbook.Path & "\*.xls")】に変えればよいのかな？と思ったのですが、完成しませんでした。

お手数ですがご教示いただけないでしょうか・・・(T_T)

何度も申し訳ありません…

どうぞよろしくお願いします。

回答No.1

SI299792

このワークブックと同じフォルダを対象にしています。
xlsxを対象にしています。
'
Option Explicit
'
Sub Macro1()
'
　　Dim FileName As String
　　Dim Sheet As Integer
　　Dim Length　As Integer
'
　　FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
'
　　While FileName > ""
　　　　Sheet = Sheet + 1
　　　　If Sheet > Sheets.Count Then
　　　　　　Sheets.Add after:=Sheets(Sheet - 1)
　　　　End If
'
　　　　Length = InStr(FileName, ".") - 1
　　　　Sheets(Sheet).Name = Left(FileName, Length)
　　　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, ReadOnly:=True
　　　　Cells.Copy ThisWorkbook.Sheets(Sheet).[A1]
　　　　Application.CutCopyMode = False
　　　　ActiveWorkbook.Close False
　　　　FileName = Dir
　　Wend
End Sub