[[20180809174451]]　『ファイル結合の際に1行目を削除する』（ももんが）　ページの最後に飛ぶ

『ファイル結合の際に1行目を削除する』（ももんが）

こんにちは。
月毎の同じ内容の複数のファイルを結合するマクロを手に入れました。
（自分で作成はしておりません）
各ファイルの1行目は見出しになっています。
2つ目のファイルからは1行目を削除して結合したいのですが、その方法を教えて頂ければと思います。
よろしくお願い致します。

Sub merge()

'シート［merge］を削除

    On Error Resume Next
    Application.DisplayAlerts = False
       Worksheets("merge").Delete
    Application.DisplayAlerts = True

'シート［merge］を一番右に追加

    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "merge"

'フォルダの場所を変数に入れる

    Dim Folder_path
    Folder_path = ThisWorkbook.Worksheets("folder").Range("b2").Value

'結合するブックを変数に入れる

    Dim FileType
    If Worksheets("folder").Range("b1").Value = "Excel" Then
        FileType = "\*.xls*"
    Else
        FileType = "\*.csv"
    End If

    Dim MergeWorkbook
    MergeWorkbook = Dir(Folder_path & FileType)

'指定したフォルダから、ファイルを探して、開いてコピペ

    Do Until MergeWorkbook = ""
        Workbooks.Open Filename:=Folder_path & "\" & MergeWorkbook

        Dim MergeWorkbook_data  '結合するブック内のシートのデータ数
        Dim ThisWorkbook_data  '結合先のシートのデータ数

        Dim i
        For i = 1 To Workbooks(MergeWorkbook).Worksheets.Count

            MergeWorkbook_data = Workbooks(MergeWorkbook).Worksheets(i).Range("a" & Rows.Count).End(xlUp).Row
            ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row

            Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)
        Next

    '結合するブックを閉じる
        Application.DisplayAlerts = False
            Workbooks(MergeWorkbook).Close
        Application.DisplayAlerts = True

'次のブックを探しに行く

        MergeWorkbook = Dir()
    Loop

End Sub

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

ざっとしか見てないので外してたらごめんなさいですけど。

＞月毎の同じ内容の複数のファイルを結合するマクロを手に入れました。
＞（自分で作成はしておりません）

月ごとかどうかわかりませんが、指定したフォルダに保存されているファイルのうち
「*.xls*」（「*.csv」モードに切り替えられる機能付き）を片っ端から開いて、開いたブックの各シートをマクロが記述されているブックの「merge」というシートに累積コピーさせていくコードに見えます。

その上で確認ですけど、質問者さんが結合したいのは、Excelブックということでよいですか？
（CSVなら、ブックとして開くのではなく、メモリ上に読み込んで結合する方法や、外部データの取込で対応する方法があるとおもうので・・・）

また、手に入れられたコードはどこまで理解できていますか？

 ・Dir関数でファイル検索してるんだな～
 ・Rows.Count.End(xlUp).Rowで最終行を調べているんだな～
 ・COPYメソッドでブック間のコピペをやってるんだな～

なんてところはピンときてますか？

気になる部分はいくつかありますけど、質問にだけ答えるなら

    ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row
    Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy _
        ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)

　　　　　　　　　　　　　↓

    ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row

    If ThisWorkbook_data = 1 Then
        Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy _
            ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)
    Else
        Workbooks(MergeWorkbook).Worksheets(i).Rows("2:" & MergeWorkbook_data).Copy _
            ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)

のように、貼付先になっているシートの最終行が1行目でなければ、2行目以降をコピーするようにしちゃうのもひとつの手だとおもいます。

（もこな２） 2018/08/09(木) 20:07

「*.xls*」を対象にするということと、ファイル名を含めたフルパスの長さが256バイトを超えないことが前提ですが、こんなコードでも動くと思います。興味があればステップ実行で研究してみてください。

    Sub 研究用()
        Dim フラグ As Boolean
        Dim dstSH As Worksheet
        Dim dstRNG As Range, srcRNG As Range
        Dim MyFolder As String, MyFile As String
        Dim tmp As Worksheet

        Stop

        'FileDialogオブジェクトでフォルダを選択させる
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                MyFolder = .SelectedItems(1)
                If MyFolder = "" Then Exit Sub
            End If
        End With

        Set dstSH = ThisWorkbook.Worksheets("まとめ")
        dstSH.Cells.Clear

        Set dstRNG = dstSH.Range("A1")

        MyFile = Dir(MyFolder & "\*.xls*")
        Do Until MyFile = ""
            With Workbooks.Open(MyFolder & "\" & MyFile)
                For Each tmp In .Worksheets
                    Set srcRNG = Intersect(tmp.UsedRange, tmp.UsedRange.Offset(Abs(フラグ)))
                    If Not srcRNG Is Nothing Then
                        srcRNG.Copy dstRNG
                        Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A")
                        フラグ = True
                    End If
                Next
                .Close
            End With

            MyFile = Dir()
        Loop

    End Sub

（もこな２） 2018/08/09(木) 23:15

失礼しました。ちょっとミスです。上記を試すなら

 Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A")
     ↓
 Set dstRNG = dstRNG.Offset(dstSH.UsedRange.Rows.Count)

に修正してください。
（もこな２） 2018/08/09(木) 23:21

もこな２様

ご回答をありがとうございました。
私のレベルはマクロの記録を改修して、selectだらけのものを作成する程度です。
（この部分はたぶん○○をしているんだな程度で、理解をしているとは言えません）

もこな２様のおっしゃる通り、片っ端から開いて、開いたブックの各シートをマクロが記述されているブックの「merge」というシートに累積コピーさせていくコードです。
ExcelとCSV、どちらも使用します。
教えて頂いた部分を変更してうまくいきました。

研究用もありがとうございました。
研究用の方ですが、

 Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A")
     ↓
 Set dstRNG = dstRNG.Offset(dstSH.UsedRange.Rows.Count)

両方を試したところ、どちらも出来たのですが、下の方は例えば4月分と5月分の間に空白行が入っていました。（データに変な空白行があるのだと思います）
上の方でも問題はないと捉えて良いのでしょうか。

（ももんが） 2018/08/10(金) 09:48

いや、問題アリです。1行目から張り付けているときに、
dstSH.UsedRange.Rows.Count
ですから、貼り付けたデータが入っている最終行になるはずです。
そこに、新たに貼り付けするとその行が上書きされてしまうはず。
なので、offsetを使わないにしても
Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count＋1, "A")
のように、最終行の次の行にしないとよろしくないとおもいます。
（もこな２） 2018/08/10(金) 11:23

＞下の方は例えば4月分と5月分の間に空白行が入っていました。（データに変な空白行があるのだと思います）
もしかしたら、何らかの書式が設定してあってそいつが原因だったりするのかもですね。
UsedRangeに依らない最終行の取得方法に切り替えた方がよいかもしれません。

コピー元のほうは、1行目からデータが始まってることが前提となりますが、こんな感じではどうですか？
（ついでに、後で調べられるようにどのブック、どのシートからコピーしてきたのか情報を付けるように改造）

    Sub 研究用2()
        Dim フラグ As Boolean

        Dim srcSH As Worksheet, srcRNG As Range, srcROW As Long
        Dim dstSH As Worksheet: Set dstSH = ThisWorkbook.Worksheets("まとめ")

        Dim MyFolder As String, MyFile As String

        Stop

        'FileDialogオブジェクトでフォルダを選択させる
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                MyFolder = .SelectedItems(1)
                If MyFolder = "" Then Exit Sub
            End If
        End With

        dstSH.Cells.Clear

        MyFile = Dir(MyFolder & "\*.xls*")
        Do Until MyFile = ""
            With Workbooks.Open(MyFolder & "\" & MyFile)

                'あえて１回だけ項目行のみコピー
                If Not フラグ Then
                    .Worksheets(1).UsedRange.Rows(1).Copy dstSH.Cells(1, "C")
                    dstSH.Range("A1:B1").Value = Array("ブック名", "シート名")
                    フラグ = True
                End If

                'ブック内の各シートをまとめシートにコピペ
                For Each srcSH In .Worksheets

                    'コピー元の最終行を取得
                    srcROW = srcSH.Cells(srcSH.Rows.Count, "A").End(xlUp).Row

                    If srcROW > 1 Then 'コピー元の最終行が1行目でなければ（データがあれば）「srcRNG」にコピー範囲をセット
                        Set srcRNG = Intersect(srcSH.UsedRange.EntireColumn, srcSH.Rows(2 & ":" & srcROW))
                        Debug.Print .Name & " ブックの "; srcRNG.Parent.Name & " シートの　"; srcRNG.Address(0, 0) & " をコピー"

                        With dstSH.Cells(dstSH.Rows.Count, "C").End(xlUp).Offset(1)
                            .Cells.Offset(, -2).Resize(srcRNG.Rows.Count).Value = srcSH.Parent.Name
                            .Cells.Offset(, -1).Resize(srcRNG.Rows.Count).Value = srcSH.Name
                            srcRNG.Copy .Cells
                        End With
                    End If
                Next srcSH

                .Close
            End With

            MyFile = Dir()
        Loop

    End Sub

（もこな２） 2018/08/10(金) 19:50

もこな２様

ご教授ありがとうございました。
また、研究用2もありがとうございました。
コピー元の情報が入るのはすごく助かります。
これを元に他のものに応用したいと思います。
お忙しい中、ありがとうございました。
（ももんが） 2018/08/13(月) 11:36

コメント返信：

[ 一覧(最新更新順) ]

[[20180809174451]] 『ファイル結合の際に1行目を削除する』（ももんが） ページの最後に飛ぶ

[[20180809174451]]　『ファイル結合の際に1行目を削除する』（ももんが）　ページの最後に飛ぶ