質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

ループ

ループとは、プログラミングにおいて、条件に合致している間、複数回繰り返し実行される箇所や、その制御構造を指します

コードレビュー

コードレビューは、ソフトウェア開発の一工程で、 ソースコードの検査を行い、開発工程で見過ごされた誤りを検出する事で、 ソフトウェア品質を高めるためのものです。

Q&A

解決済

3回答

863閲覧

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

siesta

総合スコア2

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

ループ

ループとは、プログラミングにおいて、条件に合致している間、複数回繰り返し実行される箇所や、その制御構造を指します

コードレビュー

コードレビューは、ソフトウェア開発の一工程で、 ソースコードの検査を行い、開発工程で見過ごされた誤りを検出する事で、 ソフトウェア品質を高めるためのものです。

0グッド

1クリップ

投稿2021/02/01 14:06

編集2021/02/01 15:37

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

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


###現状
→データは、「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

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

meg_

2021/02/01 15:28

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

2021/02/01 15:38

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

2021/02/01 16:14

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

2021/02/02 14:47

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

2021/02/02 15:41

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

回答3

0

ベストアンサー

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

VBA

1コード

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 '不要*****

'////シート「まとめ」以外各シートの行=1の最終列を取得(何の為?)
'///endClm = ws.Cells(1, Columns.Count).End(xlToLeft).Column '不要*****
'///シート「まとめ」以外各シートの”D”列最終行を取得(なぜD列なの?)
'///A列の「1」に変更しました
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

投稿2021/02/03 02:08

syousuke.33

総合スコア312

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

siesta

2021/02/14 15:03

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

0

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

VBA

1コード 2Sub Macro2() 3 Dim newWS As Worksheet 4 Set newWS = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1)) 5 newWS.Name = "まとめ" 6 Sheets(1).Range("A5") = "." '6行目からコピーのため 7 Dim ws As Worksheet 8 Dim i As Long 9 Dim endRow(1) As Long 10 For i = 2 To Sheets.Count 11 '***endRow(0)は「シート”まとめ”」の最終行取得 12 endRow(0) = newWS.Cells(Rows.Count, 1).End(xlUp).Row + 1 13 14 '***endRow(1)は「各シート」ごとの最終行取得 15 endRow(1) = ThisWorkbook.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row 16 17 Sheets(i).Select 18 Range(Cells(6, 1), Cells(endRow(1), 13)).Select 19 Selection.Copy 20 Sheets(1).Select 21 Cells(endRow(0), 1).Select 22 ActiveSheet.Paste 23 Application.CutCopyMode = False 24 Next i 25 Set newWS = Nothing 26End Sub

投稿2021/02/02 09:00

syousuke.33

総合スコア312

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

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

'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シート目以降を飛ばすのは新規追加した

VBA

1If srcEndClm = endClm And srcEndClm < Rows.Count Then

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

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

VBA

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

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

VBA

1endRow = newWS.Cells(Rows.Count, 1).End(xlUp).Row 2ws.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 を使えばある程度長くても素早く入力出来ます。

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

VBA

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

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

投稿2021/02/02 00:29

編集2021/02/03 06:13
退会済みユーザー

退会済みユーザー

総合スコア0

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

退会済みユーザー

退会済みユーザー

2021/02/02 01:05 編集

あと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

2021/02/02 14:37

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

2021/02/02 14:54 編集

``` 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 ```
退会済みユーザー

退会済みユーザー

2021/02/03 02:40

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問