ブック内の全シート(行が変動)を一つのシートに集約する方法をご教示ください。

Question

ブック内の全てのシート（転記先シートを除く）のデータを、同じブック内のシートに転記する方法を教えてください。

###前提・実現したいこと
シート数が6シートあるものがマクロ出力後、
「まとめ」シートが新しく自動に作られ、そこに各シートの内容が縦に集約されるようにしたい。
・イメージ
「シート１」
「シート２」
「シート３」
・
・
・

###現状
→データは、「A6」セルから入力されており、各シートによって行数が変動します。
（変動するため、最終行取得のコードで対処）
→シート数は6シート。
→転記させたいデータは、「行：変動」「列：「AからM」になります。
→転記先では、シートの「A6」セルに転記させたいです。

→調べながらコードを記述してみましたが、
実行するとすべて転記されず、1シート目と2シート目のA6行のみしか転記されない状態で、
困っております。

ご教授のほど、よろしくお願い致します。

該当のソースコード

Sub Macro1()
    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(4, Columns.Count).End(xlToLeft).Column
                endRow = ws.Cells(4, 1).End(xlDown).Row
                ws.Range(ws.Cells(4, 1), ws.Cells(endRow, endClm)).Copy newWS.Cells(4, 1)
            Else
                srcEndClm = ws.Cells(4, Columns.Count).End(xlToLeft).Column
                srcEndRow = ws.Cells(4, 1).End(xlDown).Row
                If srcEndClm = endClm And srcEndClm < Rows.Count Then
                    ws.Range(ws.Cells(6, 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

Comments

[meg_]

コードは「コードの挿入」で記入してください。

[siesta]

修正いたしました。
ご確認のほど、よろしくお願いします

[meg_]

> 実行するとすべて転記されず、1シート目と2シート目のA6行のみしか転記されない状態で、
困っております。
デバッグはされましたか？

[siesta]

デバックしましたが、どの部分で想定している処理と離れているか、わからない状況です。

[meg_]

> 実行するとすべて転記されず、1シート目と2シート目のA6行のみしか転記されない状態で、
困っております。
3シート目の処理に入ったときに注意深くデバッグしましょう。コピーされていないということは「ws.Range(ws.Cells(6, 1), ws.Cells(srcEndRow, endClm)).Copy newWS.Cells(endRow + 1, 1)」のコードが実行されていないか、想定外のセルにコピーされていませんか？

Answer 1

オブジェクト変数使うと難しいですよね
[F8]キーを押してプログラムの流れ、および変数にどこの値が格納されているか
確認しずらいですね　2回目になりますがコード記載してみます

コード

Sub Macro2回目()
Dim newWS As Worksheet
Set newWS = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1))
Set newWS = ThisWorkbook.Worksheets(1)
newWS.Name = "まとめ"

Dim ws As Worksheet
Dim endRow As Long
'Dim endClm As Long '不要****
Dim newWSRow As Long '貼付けスタート位置

'Dim srcEndClm As Long'不要****

endRow = 0
'///→転記先では、シートの「A6」セルに転記させたいです。
newWSRow = 6 'シート「まとめ」貼付けスタート位置
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "まとめ" Then

'////If endRow = 0 Then '不要*****

'////シート「まとめ」以外各シートの行=１の最終列を取得（何の為？）
'///endClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column '不要*****
'///シート「まとめ」以外各シートの”D”列最終行を取得（なぜD列なの？）
'///A列の「１」に変更しました
endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'///各シートのコピーセル範囲Rangr(Cells(4, 1),Cells(endRow, endClm))
'///[→転記させたいデータは「AからM」になります。ここでの[endClm]は[13]に書換え
ws.Range(ws.Cells(4, 1), ws.Cells(endRow, 13)).Copy newWS.Cells(newWSRow, 1)
'///シート「まとめ」貼付け後の最終列取得
newWSRow = newWS.Cells(newWS.Rows.Count, 4).End(xlUp).Row + 1
'以下不要*********************
'Else
'srcEndClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
'srcEndRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'If srcEndClm = endClm And srcEndClm < Rows.Count Then
'ws.Range(ws.Cells(4, 1), ws.Cells(srcEndRow, endClm)).Copy newWS.Cells(endRow + 1, 1)
'endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
'End If
'End If
'不要ここまで*********************
End If
Next ws
Set newWS = Nothing
End Sub

Comments

[siesta]

syousuke.33様
ありがとうございます！はじめに記載していただいた内容から、
アレンジを加え、無事解決することができました。
大変助かりました。ありがとうございました。
ベストアンサーとさせていただきます。
詰まっていた箇所としては、ws.Cells(endRow, 13)でした。

Answer 2

マクロあまり詳しくありませんがコード記載してみます。

コード
Sub Macro2()
    Dim newWS As Worksheet
    Set newWS = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1))
    newWS.Name = "まとめ"
    Sheets(1).Range("A5") = "." '6行目からコピーのため
    Dim ws As Worksheet
    Dim i As Long
    Dim endRow(1) As Long
    For i = 2 To Sheets.Count
        '***endRow(0)は「シート”まとめ”」の最終行取得
         endRow(0) = newWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
         
        '***endRow(1)は「各シート」ごとの最終行取得
         endRow(1) = ThisWorkbook.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
         
         Sheets(i).Select
         Range(Cells(6, 1), Cells(endRow(1), 13)).Select
        Selection.Copy
        Sheets(1).Select
        Cells(endRow(0), 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
    Next i
    Set newWS = Nothing
End Sub

Answer 3

大幅に見間違えていたため修正しました。

'Ctrl+↓
endRow = ws.Cells(4, 1).End(xlDown).Row
'セル終端からCtrl+↑
endRow = ws.Cells(RowsCount, 1).End(xlUp).Row

endRow = endRow + srcEndRow - 1
endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row

末尾取得はEnd(xlUp).Rowの方がいいです。
End(xlDown).Rowの影響でデータがとびとびになったり正常に動きません。
此処を直していけば想定通りの動作になるのでは？

追記
コメントに修正コードが追加されたので3点ほど気になる点をまとめました。

・forEachループは正常に動作していますし基本の処理は問題ないです。
・If分岐がおかしいです。
・変数に正常なデータが入っていません。

3シート目以降を飛ばすのは新規追加した

If srcEndClm = endClm And srcEndClm < Rows.Count Then

これが原因の可能性はあります。
srcEndClm = endClmなのですが一番最初の「処理」sheetと今の「処理」シートのcolumn数値が同じでなければ処理をしないになっています。
（まとめシートの数値は代入されていません）
Column数値にばらつきのあるsheetなら処理されないです。
srcEndClm < Rows.Countも行と列の比較になってるのでこのif文自体削除してもよさそうです。

またendRow変数がおかしいです。

If endRow = 0 Then
 endClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
 endRow = ws.Cells(Rows.Count, 4).End(xlUp).Row

最初の分岐では「処理データ」sheetのRowデータを扱っていますが

endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range(ws.Cells(4, 1), ws.Cells(srcEndRow, endClm)).Copy newWS.Cells(endRow + 1, 1)

二回目のループからは「まとめ」sheetのRowデータを扱っています。（二行目は混ざってます）
データがないシートを飛ばしたいならその後にIf srcEndRow >= 4 Thenで分岐させて良いです。

endRowやwsがどちらのsheetを指しているのか本人でも分かりづらく間違えているのが原因なので、変数名をEnemyEndRowやEnemyWorksheetなど判別出来るように書いた方がよさそうです。
（Enemyも適切ではないのですが）
自動メンバー表示のショートカットキー Ctri+J を使えばある程度長くても素早く入力出来ます。

ちなみに直すとこの形でしょうか。

'endClmは使用していないため削除
'処理一回目でnewWS.Cells(3 + 1, 1)にするため
endRow = 3
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "まとめ" Then
        '処理データのRowColumn取得
        srcEndClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        srcEndRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
        'インデックス指定エラー回避
        If srcEndRow >= 4 Then
			'ws.Cells(1, 1)ではなくws.Cells(4, 1)？
            ws.Range(ws.Cells(4, 1), ws.Cells(srcEndRow, srcEndClm)).Copy newWS.Cells(endRow + 1, 1)
    	    'まとめデータのRowを取得して次回に使用
	        endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
        End If
    End If
Next ws

処理の流れ自体はほぼ間違ってなく、変数内データが確認出来ないまま対応しようとして道を外れていった印象です。
F8のステップインを使いつつローカルウィンドウで変数データを確認すると投稿主でも案外あっさり対応できるように感じました。

Comments

[退会済みユーザー]

あとif分岐後のコピー範囲先が
ws.Range(ws.Cells(4, 1), ws.Cells(endRow, endClm)).Copy
ws.Range(ws.Cells(6, 1), ws.Cells(srcEndRow, endClm)).Copy
という風にws.Cells(4, 1)とws.Cells(6, 1)になってて何故か違うのも原因かもしれませんね

[siesta]

ご回答、ありがとうございます。
if分岐後のコピー範囲先の変更及び、末尾取得はEnd(xlUp).Rowにしたところ、シート2までは転記がうまくいきました。
それ以降のシート3,4,5は全く転記されない状況です。
変更後のソースコードを後ほど、以下に記しますので、ご教示のほどお願いいたします。

[siesta]

```
Sub Macro1()
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(Rows.Count, 4).End(xlUp).Row
ws.Range(ws.Cells(4, 1), ws.Cells(endRow, endClm)).Copy newWS.Cells(4, 1)
Else
srcEndClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column
srcEndRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
If srcEndClm = endClm And srcEndClm < Rows.Count Then
ws.Range(ws.Cells(4, 1), ws.Cells(srcEndRow, endClm)).Copy newWS.Cells(endRow + 1, 1)
endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
End If
End If
End If
Next ws
Set newWS = Nothing
End Sub
```

[退会済みユーザー]

コメント量が長く見づらかったため追加ソースへのコメントを元回答に追記でいれました。
これで3sheet目以降も改善すると思いますが確認をお願いします。