【Excel】ファイル内の複数シートの内容を新規シートにまとめる

Question

＜質問はクローズさせていただきます。＞

掲題の内容についてです。

横のデータ数はすべて同一ではあるものの、縦のデータ数が一定ではない、
複数のシートを含んだエクセルファイルにおいて、新規にシートを作成し、そのシートに全シートの内容を縦に串刺しで転記していくようなVBAを組むことは可能でしょうか。

＜シートA＞
項目タイトル｜入力会社名｜4月｜5月｜6月｜
A項目　　　 ｜A事業会社 |200 |300 | 0 |
B項目　　　 ｜A事業会社 |100 | 0 | 20 |

＜シートB＞
項目タイトル｜入力会社名｜4月｜5月｜6月｜
A項目　　　 ｜B事業会社 |100 |500 | 40 |
B項目　　　 ｜B事業会社 | 0 | 0 | 50 |
C項目　　　 ｜B事業会社 | 0 | 20 | 0 |

：
：（10シートほど、シート数は一定ではない）

上記の内容を以下のように新規シートを作ってまとめたいです。
項目タイトル｜入力会社名｜4月｜5月｜6月｜
A項目　　　 ｜A事業会社 |200 |300 | 0 |
B項目　　　 ｜A事業会社 |100 | 0 | 20 |
A項目　　　 ｜B事業会社 |100 |500 | 40 |
B項目　　　 ｜B事業会社 | 0 | 0 | 50 |
C項目　　　 ｜B事業会社 | 0 | 20 | 0 |
：
：

よろしくお願い致します。

Comments

[coco_bauer]

「縦に串刺し」を正確に定義してください。
未定義用語を使った質問は、無意味です（はっきり言うと妨害行為です）

Answer 1

こんな感じですかね。
一番左のシートの項目情報を使いその他のシートは２行目以降のデータのみをつなげています。
再度作成するときは、まとめシートを削除して実行。

Option Explicit

Sub VJoin()
    Dim newWS As Worksheet
    Set newWS = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1))
    newWS.Name = "まとめ"
    
    Dim ws As Worksheet
    Dim endRow As Long
    Dim endClm As Long
    Dim srcEndRow As Long
    Dim srcEndClm As Long
    endRow = 0
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "まとめ" Then
            If endRow = 0 Then
                endClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                endRow = ws.Cells(1, 1).End(xlDown).Row
                ws.Range(ws.Cells(1, 1), ws.Cells(endRow, endClm)).Copy newWS.Cells(1, 1)
            Else
                srcEndClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                srcEndRow = ws.Cells(1, 1).End(xlDown).Row
                If srcEndClm = endClm And srcEndClm < Rows.Count Then
                    ws.Range(ws.Cells(2, 1), ws.Cells(srcEndRow, endClm)).Copy newWS.Cells(endRow + 1, 1)
                    endRow = endRow + srcEndRow - 1
                End If
            End If
        End If
    Next ws
    Set newWS = Nothing
End Sub