ノーコードでこんなことできます
・貼り付け先シートが無いときは、指定した名前のシートが、自動で作成されます。
・処理する範囲は、見出しの行を含めたり、含めなかったりできます。
・処理する範囲は、最終行までなど変化する範囲に対応します。
・連続トリガーを使い、前処理で「見出し行をコピー」したり、後処理でフィルターにより「見出し行を削除」できます。
動画（字幕を日本語にしてください。音声なし）
アプリのコード作成画面
コードの解説
シートの有無を調べる
Sub 複数シートを１枚にする()
'◆"全社計"シートがあるか調べる
Dim 貼付シート As Worksheet, あり As Boolean
For Each 貼付シート In Worksheets
If 貼付シート.Name = "全社計" Then
あり = True
Exit For
End If
Next 貼付シート
For Eachで、シートの名前に”全社計”があるか、すべてのワークシートを調べます。
これは、”全社計”が無いと、貼り付け先が無く、エラーになるためです。
仕組みは、 If～で、”全社計”シートがあった場合、”あり”に”True"というフラグを立てるとともに、残りのシートのチェックは無駄なので、Exit ForでこのFor Each処理を終了します。
シートが無ければ追加
'◆無ければ全社計"シートを追加
If あり = False Then
Worksheets.Add before:=Worksheets(1)
ActiveSheet.Name = "全社計"
End If
変数”あり”は Boolean型で初期値はFalseです。”あり”に”True"フラグが立たなかった場合は、1番目のワークシートの前に新しいワークシートを追加し、名前を”全社計”とします。
自シートを対象外にする
'◆シートが"全社計"ではない場合、"全社計"にデータを貼り付ける
Dim シート As Worksheet
For Each シート In Worksheets
If シート.Name <> "全社計" Then
"全社計”シートのデータを”全社計”シートに貼り付けると、データが2重になります。そこで、”全社計”シートをコピー対象から除外＜＞しています。
コピーするセル範囲を取得
Dim 右下セル As String, セル範囲 As String
シート.Select
'◆最終行を取得し、セル範囲を決める
Range("a2:g2").CurrentRegion.Select
With Selection
右下セル = Cells(.Row + .Rows.Count - 1, Range("g1").Column) _
.Address(False, False)
End With
セル範囲 = "a1" & ":" & 右下セル
上の例は、範囲オプションで「最終行まで」を選んだ場合です。
範囲オプションを選ばずない場合は、下記のとおりです。
シート.Select
セル範囲 = "a2:g10"
セル範囲を、目的のシートの末尾に貼る
シート.Range(セル範囲).Copy Worksheets("全社計").
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
シート.Range(セル範囲).Copy で”セル範囲”をコピーし、
Worksheets("全社計").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)で、
”全社計”シートの最後の行の一つ下にコピーしています。
”全社計”シートか否かの条件分岐を終わらせ、次のシートに移る
End If
Next シート
End IfでIfを閉じ、Next シートで次のシートをチェックします。
最後に
Worksheets("全社計").Activate
End Sub
そして、最後に”全社計”シートをアクティブにし、終了します。