[[20200225120946]]　『フォルダ内のファイルをひとつのシートへ』（ほーむぱい）　ページの最後に飛ぶ

『フォルダ内のファイルをひとつのシートへ』（ほーむぱい）

フォルダ内にあります複数のファイルの名前のついたシート（sheet●以外）
をひとつのシートにまとめたいです

AとBとCというシートが同じフォルダ内にあった場合、
マクロのあるファイルに新しいシートを作成し、Aというシートを
コピー、その下にBというシートをコピー、その下にCというシート
をコピーというイメージです

ご指導いただけないでしょうか
宜しくお願いいたします。

＜使用 Excel：Office365、使用 OS：Windows10 ＞

フォルダブックまとめる

で学校内を検索してみてくどさい。
（OK） 2020/02/25(火) 12:36

検索し、同じようなものを見つけられました
修正したいのですが能力がなくお力をかしてもらえないでしょうか
もし見当違いのものでしたら教えてください

・フォルダはどこにあっても自動でパスを取得したいです
↓これ使えますでしょうか
Fname = Dir(ThisWorkbook.Path & "\*.xls*")

        Do While Fname <> ""	
            If Fname <> ThisWorkbook.Name Then	
                Set srcSH = Workbooks.Open(ThisWorkbook.Path & "\" & Fname).Worksheets(1)

・名前のついたシート（sheet●以外）だけというふうにしたいです
・コピーの下にコピーを繰り返したいです

Sub TEST_20050314()

    Const MyPath As String = "C:\test\"
    Dim MyBook As Workbook
    Dim MyFileName As String
    Dim MyRng As Range
    MyFileName = Dir(MyPath & "*.xls")

    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName Then
        Set MyBook = Workbooks.Open(MyPath & MyFileName)

        Set MyRng = ThisWorkbook.Sheets("まとめ").Range("A65536").End(xlUp).Offset(1)
        MyBook.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=MyRng
        MyBook.Close
        End If
        MyFileName = Dir()
    Loop
 End Sub

（ほーむぱい） 2020/02/25(火) 12:59

 こんな感じでしょうか。
 Sub Test_1()
    Dim MyBook      As Workbook
    Dim MyFileName  As String
    Dim MyRng       As Range
    Dim MySheet     As Worksheet
    Dim SH          As Worksheet
    Application.ScreenUpdating = False
    MyFileName = Dir(ThisWorkbook.Path & "\*.xls*")
    Set MySheet = Worksheets.Add(, Sheets(Sheets.Count))
    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName And Left(MyFileName, 2) <> "^$" Then
            Set MyBook = Workbooks.Open(ThisWorkbook.Path & "\" & MyFileName)
            For Each SH In MyBook.Sheets
                If Not SH.Name Like "Sheet*" Then
                    Set MyRng = MySheet.Range("A" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
                    SH.UsedRange.Copy Destination:=MyRng
                End If
            Next SH
            MyBook.Close
        End If
        MyFileName = Dir()
    Loop
    Application.ScreenUpdating = True
    MsgBox "転記しました。", vbInformation
 End Sub
（ろっくん） 2020/02/25(火) 13:26

 訂正します。
 誤：Left(MyFileName, 2) <> "^$"
 正：Left(MyFileName, 2) <> "~$"
                           ^^^^
（ろっくん） 2020/02/25(火) 15:59

ろっくんさん、ありがとうございます
ひとつのフォルダに抽出のマクロのあるファイルAと
複数のファイルB～Hを入れて実行しました
結果、コピーの最終行の下にコピーが貼りつけられていないようです
もしかしてコピーした上に上書きされていますでしょうか。

あと訂正しましたら構文エラーとなってしまいました

（ほーむぱい） 2020/02/25(火) 16:04

 うーん、こちらのテストではうまくいくのですが・・
 下記実行してみてください。転記元と転記先を毎度表示します。
 質問者さんの意図と一致しますか？

  Sub Test_2()
    Dim MyBook      As Workbook
    Dim MyFileName  As String
    Dim MyRng       As Range
    Dim MySheet     As Worksheet
    Dim SH          As Worksheet

    MyFileName = Dir(ThisWorkbook.Path & "\*.xls*")
    Set MySheet = Worksheets.Add(, Sheets(Sheets.Count))
    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName And Left(MyFileName, 2) <> "^$" Then
            Set MyBook = Workbooks.Open(ThisWorkbook.Path & "\" & MyFileName)
            For Each SH In MyBook.Sheets
                If Not SH.Name Like "Sheet*" Then
                    Set MyRng = MySheet.Range("A" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
                    MsgBox MyFileName & "の" & "シート「" & SH.Name & "」の " & SH.UsedRange.Address(0, 0) & " を " & MyRng.Row & "行目から下にコピーします。"
                    SH.UsedRange.Copy Destination:=MyRng
                End If
            Next SH
            MyBook.Close
        End If
        MyFileName = Dir()
    Loop

    MsgBox "転記しました。", vbInformation
 End Sub
（ろっくん） 2020/02/25(火) 16:39

UsedRangeで選択された範囲をコピペ繰り返してますよ
罫線だけのところも範囲に入ります
下にスクロールしてみましょう

もしかしてタイトルを除きデータのある最終行までを
繰り返しコピペしたいのかな？？
（siro） 2020/02/25(火) 20:34

[[20200222194525]]の件ほっぽりだしでいいのですか。

（rok） 2020/02/25(火) 20:51

ろっくんさん、ごめんなさい
スクロールしたらありました
私の説明が不足してました
siroさんの言うとおりタイトルを除きデータのある最終行までを繰り返し
最終行の下にコピーが貼りつけらられるようにしたいです
間違っていたらごめんなさい
ここを変更したら思うようにできますか？
Set MyRng = MySheet.Range("A" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
頑張って調べてみます

（ほーむぱい） 2020/02/27(木) 09:50

 Set MyRng =　～　の部分は貼り付け先の位置を示しています。
 変更する箇所はコピーする部分なので下記ですよ。
 SH.UsedRange.Copy Destination:=MyRng
    ^^^^^^^^^^
 範囲の指定方法をいろいろ調べてみてください。
（ろっくん） 2020/02/27(木) 10:28

ろっくんさん、また間違えてたらごめんなさい
最初の書き出しを3行目にタイトルで4行目にしようと思います
それはSet MyRng を変更したら大丈夫ですか？

あと範囲の指定を調べてやってみました
なんでだろう同じものが少しづつづれて3回コピーされちゃいました
もうちょっと調べてみます

Sub Test_2()

    Dim MyBook      As Workbook
    Dim MyFileName  As String
    Dim MyRng       As Range
    Dim MySheet     As Worksheet
    Dim SH          As Worksheet
    Dim i           As Long
    Dim lRow        As Long

    MyFileName = Dir(ThisWorkbook.Path & "\*.xls*")
    Set MySheet = Worksheets.Add(, Sheets(Sheets.Count))
    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName And Left(MyFileName, 2) <> "^$" Then
            Set MyBook = Workbooks.Open(ThisWorkbook.Path & "\" & MyFileName)
            For Each SH In MyBook.Sheets
                If Not SH.Name Like "Sheet*" Then
                 lRow = Cells(Rows.Count, 4).End(xlUp).Row
                  For i = 11 To lRow
                    Set MyRng = MySheet.Range("A" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
                    MsgBox MyFileName & "の" & "シート「" & SH.Name & "」の " & SH.UsedRange.Address(0, 0) & " を " & MyRng.Row & "行目から下にコピーします。"
                    SH.Range(Rows(11), Rows(i)).Copy Destination:=MyRng
                  Next i
                End If
            Next SH
            MyBook.Close
        End If
        MyFileName = Dir()
    Loop

    MsgBox "転記しました。", vbInformation
 End Sub
（ほーむぱい） 2020/02/27(木) 15:40

 ・提示いただいたものだと11行目からとなってますけど4行目以下ですね。
 ・for～Next内で範囲を1行ずつ広げながらコピーを繰り返していますが、
 　ここは開始行と最終行を取得できれば1回で済みます。
 ・RowsとかCellsとかシートオブジェクトを明記（SH.Cells～みたいに）しないと
　 アクティブシートが対象になってしまいますよ。
  （特に今回のような複数シートを扱うようなものは注意です。）

 このような感じだとどうでしょうか。

 Sub Test_3()
    Dim MyBook      As Workbook
    Dim MyFileName  As String
    Dim MyRng       As Range
    Dim MySheet     As Worksheet
    Dim SH          As Worksheet
    Dim i           As Long
    Dim lRow        As Long
    MyFileName = Dir(ThisWorkbook.Path & "\*.xls*")
    Set MySheet = Worksheets.Add(, Sheets(Sheets.Count))
    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName And Left(MyFileName, 2) <> "~$" Then
            Set MyBook = Workbooks.Open(ThisWorkbook.Path & "\" & MyFileName)
            For Each SH In MyBook.Sheets
                If Not SH.Name Like "Sheet*" Then
                    lRow = SH.Cells(SH.Rows.Count, 4).End(xlUp).Row
                    Set MyRng = MySheet.Range("A" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
                    SH.Range(SH.Rows(4), SH.Rows(lRow)).Copy Destination:=MyRng
                End If
            Next SH
            MyBook.Close
        End If
        MyFileName = Dir()
    Loop
    MsgBox "転記しました。", vbInformation
 End Sub
（ろっくん） 2020/02/27(木) 16:27

ろっくんさん、また私の説明が不足してました
フォルダ内にあります複数のファイルはタイトルが10行目でございます
完成シートの最初の貼り付け先を3行目タイトル、4行目以降にしようと思います

Set MyRng = MySheet.Range("A4" & MySheet.UsedRange.Rows(MySheet.UsedRange.Rows.Count).Row + 1)
としてみましたがエラーが出るようになりました

間違っていたらごめんなさい

 SH.Range(SH.Rows(4), SH.Rows(lRow)).Copy Destination:=MyRng
ここで開始行と最終行を取得しているんですよね？

綺麗にコピーされるようになりました
複数のファイルの中にデータが無い場合もあるのですが
なんでだろう、そのファイルだけタイトルと空白行が1行コピーされました
あっ！データが無い場合は次のファイルっていうのを追加したら大丈夫ですか？
ちょっと頑張ってみます

（ほーむぱい） 2020/02/28(金) 13:07

 私の理解不足だったようです、すみません。

 > SH.Range(SH.Rows(4), SH.Rows(lRow)).Copy Destination:=MyRng
 > ここで開始行と最終行を取得しているんですよね？

 →ここは開始行と最終行を取得しているわけではなく、指定しているだけですよ。
　 開始行は11行目で固定ですから SH.Rows(11) でいいです。
   最終行については　lRow = SH.Cells(SH.Rows.Count, 4).End(xlUp).Row　で
   取得していますので、lRowの値が11以上の場合のみコピーするというような
   IF文で条件を入れてはどうでしょうか。

  If lRow >= 11 Then
     （コピーするコード部分）
  End If
（ろっくん） 2020/02/28(金) 13:57

そっか、lRowの値が11以上の場合と考えればスマートですね
まだ途中ですがExit forを考えてました

　For i = 11 To lRow

  　If Cells(4, i).Value = "" Then

  　Exit for

（ほーむぱい） 2020/02/28(金) 15:35

コメント返信：

[ 一覧(最新更新順) ]

[[20200225120946]] 『フォルダ内のファイルをひとつのシートへ』（ほーむぱい） ページの最後に飛ぶ

[[20200225120946]]　『フォルダ内のファイルをひとつのシートへ』（ほーむぱい）　ページの最後に飛ぶ