VBA:複数シートを一枚のシートにまとめる

Question

前提・実現したいこと

複数シートのデータを一枚のシートにまとめたいです。

シートの並びとしては、
結合シート➔Sheet1➔Sheet２➔Sheet3
となっていて、
Sheet1,Sheet2,Sheet3のデータを結合シートにまとめたいです。

ちなみにSheet1Sheet3のデータは全部同じ形式で、見出しも入っています。
以下のコードですと、見出しも含まれて結合してしまうので
Sheet2からは見出しなし(2行目転記)したいです。

ちなみに、結合シートの7行目から貼り付けていきたいです。

該当のソースコード

Sub test()

  
   
    'すべてのシートで処理
    Dim i As Long
    Dim w As Worksheet
   
    
    For i = 2 To Worksheets.count
    
     Set w = Worksheets(i)
     
        'ただし、シート名が「結合シート」を除く
        If w.Name <> "結合シート" Then
        
            'コピーする各シートのデータで最も下にあるデータの行を探す（A列にデータがあることが前提）
            Dim From_Max_Row As Long
            From_Max_Row = w.Range("a" & Rows.count).End(xlUp).Row
            
            '貼り付け先のシート「結合シート」で最も下にあるデータの行を探す
            Dim To_Max_Row As Long
            To_Max_Row = Worksheets("結合シート").Range("a" & Rows.count).End(xlUp).Row + 1
           
           '各シートのデータを1行目からすべてコピーし、「結合シート」に貼り付けていく
           w.Rows("1:" & From_Max_Row).Copy Worksheets("結合シート").Range("a" & To_Max_Row)
           
        End If
    Next
    
            Worksheets("結合シート").Rows(1).Delete

End Sub

Answer 1

見出しだけ先にコピーしておいて、Sheet1~Sheet3のデータを２行目からコピーする感じでどうですか？

Sub test()
    Dim k As Worksheet, w As Worksheet
    Set k = Worksheets("結合シート")
    For Each w In Worksheets
        If w.Name <> k.Name Then
            w.Rows(1).Copy k.Rows(7)
            Dim f As Range, t As Range
            Set f = w.UsedRange.Resize(w.UsedRange.Rows.Count - 1).Offset(1)
            Set t = k.Range("A" & k.Rows.Count).End(xlUp).Offset(1)
            Debug.Print f.Address(, , , True), t.Address(, , , True)
            f.Copy t
        End If
    Next
End Sub

Comments

[pomiw0000]

ありがとうございます!!
一旦やってみようと思います。

[pomiw0000]

それ以降を8行目から貼り付けたい場合はどうすればいいでしょうか。

[jinoji]

それ以降とは？

[pomiw0000]

見出し以外のデータです。

[jinoji]

w.UsedRange.Resize(w.UsedRange.Rows.Count - 1).Offset(1) が見出し以降のデータで
k.Range("A" & k.Rows.Count).End(xlUp).Offset(1)が8行目となるはずですが、そうなりませんか？

[pomiw0000]

8行目からではなく、なぜかものすごい下の行に見出しありでデータが入ってしまっています。

[pomiw0000]

7行目には見出しだけが入っています

[jinoji]

コピー元とコピー先のアドレスを確かめるためにDebug文を入れてみました。
これを実行するとどうなりますか？

[pomiw0000]

今度は見出しだけが貼り付けられてデータはない状態です????

[jinoji]

イミディエイトウィンドウに、コピー元とコピー先のアドレスが書き出されているはずですので、
それを確認してみてください。

Answer 2

元のコードに加筆してみました。
Sheet1とSheet2以降のコピー開始位置を変えれば綺麗にまとめることができます。

Sub test()

    'すべてのシートで処理
    Dim i As Long
    Dim w As Worksheet

    For i = 2 To Worksheets.Count

     Set w = Worksheets(i)

        'ただし、シート名が「結合シート」を除く
        If w.Name <> "結合シート" Then

            'コピーする各シートのデータで最も下にあるデータの行を探す（A列にデータがあることが前提）
            Dim From_Max_Row As Long
            From_Max_Row = w.Range("a" & Rows.Count).End(xlUp).Row

            '貼り付け先のシート「結合シート」で最も下にあるデータの行を探す
            Dim To_Max_Row As Long

            If i = 2 Then
                'Sheet1は見出しが設定されていないため最終行=1とする
                To_Max_Row = 1
                '各シートのデータを1行目からすべてコピーし、「結合シート」に貼り付けていく
                w.Rows("1:" & From_Max_Row).Copy Worksheets("結合シート").Range("a" & To_Max_Row)
                
            Else
                'Sheet2以降の処理
                To_Max_Row = Worksheets("結合シート").Range("a" & Rows.Count).End(xlUp).Row + 1
                '各シートのデータを2行目からすべてコピーし、「結合シート」に貼り付けていく
                w.Rows("2:" & From_Max_Row).Copy Worksheets("結合シート").Range("a" & To_Max_Row)
                
            End If
        
        End If
        
    Next

            Worksheets("結合シート").Rows(1).Delete

End Sub

Answer 3

一例です。
※7行目から転記するように修正しました。

Sub test2()
    Dim wMerge As Worksheet
    Set wMerge = Worksheets("結合シート")

    Dim newRng As Range
    Set newRng = wMerge.Range("A7")

    Dim w As Worksheet
    For Each w In Worksheets
        If w.Name <> wMerge.Name Then
            Dim offsetRow As Long
            With w.Cells(1).CurrentRegion
                .Offset(offsetRow).Copy newRng
                Set newRng = newRng.Offset(.Rows.Count - offsetRow)
            End With
            If offsetRow = 0 Then offsetRow = 1
        End If
    Next
End Sub

Comments

[pomiw0000]

ありがとうございます!!
ちなみに、結合シートに貼り付ける際に7行目から貼り付けたい場合はどうすればいいでしょうか。

[hatena19]

6行目は空欄ですか。それとも何か入力されてますか。

[pomiw0000]

空欄です!!

[hatena19]

空欄でも入力されていてもOKなコードに修正しましたので、回答を参照ください。

[pomiw0000]

ありがとうございます。
7行目からコピーはできたのですが、連続でデータが表示されずに
何行か下の行に表示されてしまいます。????

[pomiw0000]

データとデータの間になぜか、空欄のセルの行がたくさんできてしまいます。