ここから本文です

ご教授ください。 フォルダー内に「○○.xlsx」「□□.xlsx」「△△.xlsx」・・・と複数...

tgz********さん

2018/1/1007:07:51

ご教授ください。
フォルダー内に「○○.xlsx」「□□.xlsx」「△△.xlsx」・・・と複数のxlsxファイルを入れ、そのフォルダー内にある「集約マクロ.xlsm」でマクロを実行すると、新しく「集約ファイル.xlsx」という

ファイルが作成され、そのsheet1に 「○○.xlsx」「□□.xlsx」「△△.xlsx」・・・の複数ファイルにあるデータが順番に下に結合(貼り付け)されるようなものが作れません。
どうぞよろしくお願い致します。

追記:
・「○○.xlsx」「□□.xlsx」「△△.xlsx」・・・は全て同じ書式となっておりま す。ただし、列数は同じですが行数は異なります。
・「○○.xlsx」「□□.xlsx」「△△.xlsx」・・・は1行目にそれぞれ項目名が記されています。できれば結合されたデータは、項目名は1行目の最初だけで、後に貼り付けられていくデータには、その各ファイル(「□□.xlsx」 「△△.xlsx」・・・)の項目名は削除された状態で貼り付けていただきたいです。
・一応ですがA列に空白は存在しません。
・フォルダー内に入れるファイル数は(「○○.xlsx」「□□.xlsx」 「△△.xlsx」・・・)いつも同じ数ではありません。

補足質問の意図が十分お伝えしきれず申し訳ありません。
手作業なら当然できるのですが、マクロ初心者で、ネットで検索してもなかなか自分の求めているものに辿り着くことができずここに質問させてもらいました。
できれば標準モジュールに貼り付けしたら完成するようなマクロの式(?)を教えてもらいたいと思っています。

どこまで出来たかと聞かれれば、

Sub matome()
Application.ScreenUpdating = False
Set mb = ThisWorkbook
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xlsx")
Do Until fname = Empty
If fname <> mb.Name Then
Set wb = Workbooks.Open(myfdr & "\" & fname)
wb.Worksheets.Copy Before:=mb.Sheets(mb.Sheets.Count)
wb.Close
End If
fname = Dir
Loop
Application.ScreenUpdating = True
End Sub

こういった感じなのですが、これでは1つのファイルに複数のシートで貼り付けされるので、これは求めているものと違っています。しかしここからどう修正していいのか分からず困っている状況です。
上記と全く異なった、もっと簡単なマクロ式でも構いません。ご教授よろしくお願い致します。

閲覧数:
97
回答数:
3

違反報告

ベストアンサーに選ばれた回答

fro********さん

2018/1/1009:51:32

こんな感じでしょうか


Sub matome()
Dim myfdr As String, fname As String
Dim mb As Workbook, wb As Workbook
Dim WLrow As Long, Lrow As Long, Lcol As Long

Application.ScreenUpdating = False

myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\" & "*.xlsx")
Set mb = Workbooks.Add
mb.SaveAs Filename:=myfdr & "\集約ファイル.xlsx"

Do Until fname = ""
WLrow = mb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
If fname <> mb.Name Then
Workbooks.Open Filename:=myfdr & "\" & fname
Set wb = ActiveWorkbook
With wb.Sheets(1)
Lrow = .Range("A" & Rows.Count).End(xlUp).Row
Lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(Cells(1, 1), Cells(1, Lcol)).Copy
mb.Sheets(1).Cells(1, 1).PasteSpecial
.Range(.Cells(1, 1), .Cells(Lrow, Lcol)).Copy
mb.Sheets(1).Cells(WLrow, 1).PasteSpecial
End With
wb.Close savechanges:=False
Set wb = Nothing
End If
fname = Dir()
Loop

Application.ScreenUpdating = True
End Sub

  • 質問者

    tgz********さん

    2018/1/1010:37:56

    とても早く作成していただき本当に感謝です。
    ありがとうございます!
    早速試させていただきました。今までで一番自分が思い描いたものに近くとても有難かったのですが、すみません、欲を言わせていただきますと、
    どうしても、2つめ以降のファイルの中の1行目の“項目名”が消えていない状態で結合されてしまいます。
    手作業でフィルターをかけて消せば済む話なのですが、完成したデータにも1行目の“項目名”以外は存在しない状態にできればベストです。
    本当に作っていただいて申し訳ありませんが、その問題だけ解消できれば完璧なのでよろしくお願い致します。

  • その他の返信(1件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2018/1/10 15:21:01

今回お二方共にいただきましたマクロ式で、求めていた完璧なものを作成することができました。
本当にどうもありがとうございました。

ベストアンサーを選ばせていただくに当たり、悩みましたが、ご返信が早く最初に答えに辿り着けたfrom_north_snowさんをベストアンサーに選ばせていただきました。

jiyu128さん、sheet名を明記していなかった点は申し訳ありませんでした。実はsheet名は「

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

jiy********さん

2018/1/1011:15:11

これでいかがでしょうか。

Sub matome()
Dim nb As Workbook
Dim wb As Workbook
Dim fname As String
Dim myfdr As String
Dim lRow As Long
Dim echSh As Worksheet

Application.ScreenUpdating = False
myfdr = ThisWorkbook.Path

Set nb = Workbooks.Add()
nb.SaveAs Filename:=myfdr & "\集約ファイル.xlsx"
For Each echSh In nb.Worksheets
If echSh.Name <> "Sheet1" Then
echSh.Delete
End If
Next echSh

fname = Dir(myfdr & "\*.xlsx")
Do Until fname = Empty
If fname <> nb.Name And fname <> "集約ファイル.xlsx" Then
Set wb = Workbooks.Open(myfdr & "\" & fname)
lRow = nb.Sheets("Sheet1").Cells(nb.Sheets(1).Rows.Count, 1).End(xlUp).Row
If lRow = 1 Then
wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Copy
nb.Sheets("Sheet1").Cells(1, 1).PasteSpecial
Else
wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Offset(1, 0).Copy
nb.Sheets("Sheet1").Cells(lRow + 1, 1).PasteSpecial
End If
nb.Save
wb.Close
End If
fname = Dir()
Loop
nb.Sheets("Sheet1").Cells(1, 1).Select
nb.Save
nb.Close

Application.ScreenUpdating = True
Set echSh = Nothing
Set wb = Nothing
Set nb = Nothing
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

hon********さん

2018/1/1009:03:29

結合(貼り付け)されるようなものが作れません・・・・
どこまで出来たのでしょうか???
補足して修正すれば可能では

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる