[[20220808074628]]　『vba 各シートの品番欄と合計欄とシート名を転記』（葉月）　ページの最後に飛ぶ

『vba 各シートの品番欄と合計欄とシート名を転記』（葉月）

	お世話になります。
	１ページ（シート）目に設定シート、２ページ目に統合シート、３ページ以下に集計シートが10～20あります。
	２ページ目の統合シートに３ページ以降の
	品番欄と合計欄とシート名を縦並べに転記するマクロを教えて下さい。
	・集計シートのフォームは一つのファイルとしてはすべて同じ
	・集計シートの行数・列数は配信される都度変動するので、コピー元セルは１ページ目の設定シート　C3～C7を引用
	以下各シートのレイアウトです。

	◆設定シート　（集計シートのセル位置設定）
	B		C
	――――――――――――――		
	3｜品番先頭		C9
	4｜品番最後		C508
	5｜小計先頭		AS9
	6｜小計最後		AS508
	7｜合計先頭		AX9
	8｜合計最後		AX508
	9｜１シート行数		500

	◆集計シート
		C	D	E	…	AS	…	AX
	―――――――――――――――――――――――――――――――							
		品番	項目1	項目2	…	小計	…	合計
	9｜	H11				100		300
	10｜	H27				120		100
		　｜						
		　｜						
	508｜	H86				130		200

	◆統合シート　（処理後イメージ）
		C	D	E	F
	――――――――――――――――――――				
	3｜	品番	小計	合計	シート名
	4｜	H11	100	300	sh1
	5｜	H27	120	100	sh1
	　　｜				
	　　｜				
	503｜	H86	130	200	sh1
	504｜	H210	500	4000	sh2
	505｜	H223	600	3800	sh2
	　　｜				
	　　｜				
	1003｜	H240	700	5000	sh2

	◆流れ
	3枚目集計シートのC9:C508コピーして
	統合シートのC4へ値貼り付け
	3枚目シートのAS9:AS508コピーして
	統合シートのD4へ値貼り付け
	3枚目シートのAX9:AX508コピーして
	統合シートのE4へ値貼り付け
	統合シートのF列はシート名表示

	4枚目シートのC9:C508コピーして
	統合シートのC504へ値貼り付け
	4枚目シートのAS9:AS508コピーして
	統合シートのD504へ値貼り付け
	4枚目シートのAX9:AX508コピーして
	統合シートのE504へ値貼り付け
	統合シートのF列はシート名表示

	以下最終のシートまで繰り返し
	よろしくお願いします。

＜使用 Excel：Office365、使用 OS：Windows10 ＞

＞品番欄と合計欄とシート名を縦並べに転記するマクロを教えて下さい。
何回か読み直しましたが、よく理解できません。

とりあえず、【現状】どのようなコードを書いていて、【どのように】希望と違っているのか説明されてはどうですか？

（もこな２） 2022/08/08(月) 08:29

統合シートの C504 (以下同じ) は C509 じゃないんですか。
其れだと C504～C508 は上書きされますよ。
（?） 2022/08/08(月) 09:39

	もこな２さん　
	これでどうでしょう？
	20枚のシートから一つのシートに単にコピペするだけならわかるのですが、
	セル位置変動への対応やシート名の取得が分かりません。

	’シート名　「sh1」　集計シート１ページ目を転記　　シート数は10～20　シート名も毎回変動
	    Sheets("sh1").Select
	    Range("C9:C508").Select　　　’品番　　範囲は設定シートのC3～C4から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("C4").PasteSpecial xlPasteValues

	    Sheets("sh1").Select
	    Range("AS9:AS508").Select　　’小計　　範囲は設定シートのC5～C6から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("D4").PasteSpecial xlPasteValues

	    Sheets("sh1").Select
	    Range("AS9:AS508").Select　　’合計　　範囲は設定シートのC7～C8から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("E4").PasteSpecial xlPasteValues

	    F4　～　F503　までシート名(sh1)を表示

	’シート名　「sh2」　集計シート２ページ目を転記　　シート数は10～20　シート名も毎回変動
	    Sheets("sh2").Select
	    Range("C9:C508").Select　　　’品番　　範囲は設定シートのC3～C4から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("C504").PasteSpecial xlPasteValues　　　’セル位置はC4　+　設定シートのC9の行数（500）をプラス

	    Sheets("sh2").Select
	    Range("AS9:AS508").Select　　’小計　　範囲は設定シートのC5～C6から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("D504").PasteSpecial xlPasteValues　　　’セル位置はC4　+　設定シートのC9の行数（500）をプラス

	    Sheets("sh2").Select
	    Range("AS9:AS508").Select　　’合計　　範囲は設定シートのC7～C8から取得
	    Selection.Copy
	    Sheets("統合").Select
	    Range("E504").PasteSpecial xlPasteValues　　　’セル位置はC4　+　設定シートのC9の行数（500）をプラス

	    F504　～　F1003　までシート名（sh2）を表示

	以下最後のシートまで繰り返し

（葉月） 2022/08/08(月) 09:51

 （?） さん
 集計シートは９行目から、統合シートは４行目から　なので上書きはされないと思うのですが、
 私勘違いしていますか？

 １シート目のデータが統合シートの4～503行にあるので、その続きの504～1003に二番目の集計シートデータを転記

（葉月） 2022/08/08(月) 09:58

 Sub wSchk()
    Dim i             As Long
    For i = Worksheets.Count To 3 Step -1
        MsgBox Worksheets(i).Name
    Next
End Sub
ループ処理を少し、研究されては如何でせうか。。。＾＾；
でわ
m(_ _)m
（隠居Z） 2022/08/08(月) 10:06

完全に私の勘違いでした。
申し訳ありません。
（?） 2022/08/08(月) 10:11

書いている間に話が進んでいますが、投稿しておきます。

再々度よみかえしてなんとなくわかりました。
１シート目は全く無視してよい話ですね。

すなわち、

 (1) 3番目～最後のシートまで巡回して
 (2) n番目のシートのC9:C508,AS9:AS508,AX9:AX508セルを一括コピー
 (3) 統合シートのC4セルから((n-3)*500)下がったセルへ値貼り付け
 (4) 統合シートのF4セルから((n-3)*500)下がったセルを起点にして、500行分n番目のシート名を書き込む
 (5) (2)～(4)を繰り返す

という処理ですね。テストしてないですが、たぶんこんな感じになるのではないですか？

    Sub テキトー()
        Dim n As Long

        For n = 3 To Worksheets.Count
            With Worksheets(n)
                .Range("C9:C508:AS9:AS508:AX9:AX508").【コピーする命令】
                Worksheets("統合シート").Range("C4").Offset((n - 3) * 500).【値のみ貼付する命令】
                Worksheets("統合シート").Range("F4").Offset((n - 3) * 500).Resize(500).Value = Worksheets(n).Name
            End With
        Next n
    End Sub

（もこな２） 2022/08/08(月) 10:31

 もこな２さん　テストしたところこれで一旦動きました。

 ただ
 >１シート目は全く無視してよい話ですね。
 ここ違います。

 .Range("C9:C508,AS9:AS508,AX9:AX508")　の「３カ所の範囲」と
 Worksheets("統合シート").Range("C4").Offset((n - 3) * 500)　の「500」は記載の通り１シート目（設定シート）を参照したいのです。

（葉月） 2022/08/08(月) 11:44

 セルはString型の変数、500はLong型の変数に入れて、
 その変数を使って指定するように修正してみてください。
（ax） 2022/08/08(月) 12:31

また、話が前後しますが、投稿しておきます。
基本的な考え方は既に示した通りですが、【現状】のコードを拝見して何点か

■１
VBAの世界では基本的にシートやセルなど（オブジェクトと言います）をきちんと明示すれば、いちいちアクティブにしたり選択したりする必要はありません。
また、【標準モジュール】でシートの指定を省略するとActiveSheetを指定したとみなされるルールです。
したがって、きちんと対象のオブジェクトを明示するようにすると、無駄な選択をしなくて済みますしコードもすっきりと書くことができます。さらに、コードを整理することで全体構造が把握しやすくなりご自身のデバッグ作業の効率アップに寄与するとおもいます。

■２
「シート名の取得が分かりません。」とのことですが、単純にシートオブジェクトのNamaプロパティを調べればわかります。

 今回は○番目のシートという【インデックス番号】から、そのシートの名前を調べればOKですが、シート名が「sh1」「sh2」...のような感じであれば、"sh"という【文字列】と"1"という【数値】を【文字列結合】することでも、シート名を得ることは可能です。

■３
今回は500行固定のようですが、この手の処理は、最初のシートは項目行あり・そのほかのシートは項目行抜きでデータのある分だけ処理したいという話になりがちです。
　また、○○という条件のものだけ抜き出して、転記したいということもあるとおもいます。
そのような場合には、【フィルタオプション】で抜き出して転記する、【オートフィルタ】で抽出して転記するといった方法が有効です。余力のある時に研究されるとよいでしょう。

■５
＞テストしたところこれで一旦動きました。
＞ >１シート目は全く無視してよい話ですね。
＞ここ違います。
こちらとしては完成品のプレゼントではなく、研究用のコードを示しているつもりです。
まずは、ご自身でトライしてみて、それでも解決しなければ追加で相談されてはどうですか？

 (その【文字列】がどこに入るか理解できていれば容易いでしょう）

なお、行数はともかく、列や開始行が固定されているのであれば↓のようなことで事足りるとおもいますし、各シートごとに行数が異なるならば、n番目のシートの最終行を調べれば行数は計算できますよね。

    Sub テキトー_改()
        Dim n As Long
        Dim dstRNG As Range
        Dim 行数 As Long

        Stop 'ブレークポイントの代わり

        行数 = Worksheets("設定シート").Range("C9").Value
        Set dstRNG = Worksheets("統合シート").Range("C4")

        For n = 3 To Worksheets.Count
            With Worksheets(n)
                Intersect(.Rows(9).Resize(行数), Range("C1,AS1,AX9").EntireColumn).Copy
                dstRNG.PasteSpecial xlPasteValues
                dstRNG.Offset(, 4).Resize(500).Value = .Name
            End With

            Set dstRNG = dstRNG.Offset(行数)
        Next n
    End Sub

（もこな２） 2022/08/08(月) 12:53

追加で。

■６
研究用としてもう一つ提供しておきます。

    Sub 別案()
        Dim ws As Worksheet
        Dim 最終行 As Long, 出力行 As Long

        Stop 'ブレークポイントの代わり
        出力行 = 4

        For Each ws In Worksheets
            Select Case ws.Name
                Case "設定シート", "統合シート"
                    'なにもしない
                Case Else
                    最終行 = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
                    If 最終行 >= 9 Then
                        Intersect(ws.Rows("9:" & 最終行), ws.Range("C:C,AS:AS,AX:AX")).Copy
                        '↑が理解できない場合↓で
                        'ws.Range("C9:C" & 最終行 & ",AS9:AS" & 最終行 & ",AX9:AX" & 最終行).Copy

                        Worksheets("統合シート").Cells(出力行, "C").PasteSpecial xlPasteValues
                        Worksheets("統合シート").Cells(出力行, "F").Resize(最終行 - 8).Value = ws.Name

                        出力行 = 出力行 + 最終行 - 8
                        '500行決め打ちにしたければ↑を【出力行+500】にするだけ
                    End If
            End Select
        Next ws
    End Sub

（もこな２） 2022/08/08(月) 17:12

	もこな２　さん
	昨日から試行錯誤していました。
	結論から言うと　17:12のコードでうまくいきました。
	丁寧なご回答・多くのアドバイス、ありがとうございました。
	まだまだ一部分しかvbaは理解できていません。
	返信を準備していたので書いておきます。

	>最初のシートは項目行あり・そのほかのシートは項目行抜きでデータのある分だけ処理したいという話になりがちです。
	はい。なのでデータ部分だけ（９行目から）抜き出しています。サンプルもそのように記載しています。

	> 今回は500行固定のよう
	サンプルは500ですが、発行の都度変更するので
	「コピー元セルは１ページ目の設定シート　C3～C7を引用」と考えています。

	> 【オートフィルタ】で抽出
	はい。各シート（20）ごとにフィルターをかけるより、すべてを縦に並べてから一回でフィルターをかけようと思っています。

	> 研究用のコードを示しているつもりです
	>> Range("C9:C508:AS9:AS508:AX9:AX508")　この範囲指定の仕方を見てそう思っています。

	> 各シートごとに行数が異なるならば
	どこにもそのようなことは記載していません。
	一番最初に
	「集計シートのフォームは一つのファイルとしてはすべて同じ」
	と記載しています。

	12:53 のコードは下記で実行時エラーとなります。
	                Intersect(.Rows(9).Resize(行数), Range("C1,AS1,AX9").EntireColumn).Copy

	ax　さん
	> セルはString型の変数、500はLong型の変数に入れて、
	> その変数を使って指定するように修正してみてください。
	まさにこのコードをお聞きしたかったのですが…。

（葉月） 2022/08/09(火) 08:33

教えてください。わたしも、一緒に「研究」させてください。
１）設定シートで C9も可変でしょうか？

 ＞品番先頭		C9

２）各集計シートの１～7行に空白行はありますか？
３）各集計シートのA、B列に空白列はありますか？

（マナ） 2022/08/09(火) 09:39

 マナさん　 お付き合いいただきありがとうございます。

 1）C9も可変です。私書き間違えて違えていますね。すいません。
　　C3～C9　すべて可変です。こうしておいた方が柔軟に対応できると思いました。

 2）空白行がある時ない時、両方あります。
 3）空白列がある時ない時、両方あります。

（葉月） 2022/08/09(火) 16:49

マクロブックは別にあって、集計対象のブックと両方開いた状態で開始する
ということで間違いないですか。

（マナ） 2022/08/09(火) 17:04

追加で

１）集計シートの１行目が空白行になることはありますか
２）集計シートのA1セルが空白以外のことはありえますか
３）集計シートの開始行ではなく、開始列（品番の列）がC列以外になることはありますか

（マナ） 2022/08/09(火) 17:11

ちょうどPower Queryのマクロ利用の勉強をしていたところだったので
題材としては、適当とはいえませんが、とりあえず使ってみました。
実際は、マクロブックに手作業でクエリを作成しておいて
マクロではクエリの更新結果だけをコピペするのがよいと思います。

なお設定シートの情報は利用していません。

 Sub test()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim r1 As Long, r2 As Long, n As Long
    Dim dst As Range
    Dim qry As WorkbookQuery
    Dim f As String
    Dim tbl As ListObject
    Const qryName = "qry統合202208"

    Set wb = ActiveWorkbook
    wb.Save

    For Each ws In wb.Worksheets
        If ws.Name <> "統合" And ws.Name <> "設定" Then
            With ws.UsedRange
                r1 = .Find(what:="*", after:=.Cells(.Cells.Count), lookat:=xlWhole, searchorder:=xlByRows).Row
                r2 = .Find(what:="品番").Row
            End With
            n = r2 - r1
            Exit For
        End If
    Next

    Set ws = wb.Worksheets("統合")
    Set dst = ws.Range("C3").Resize(100000, 4)
    dst.Clear

    f = "let ソース = Excel.Workbook(File.Contents(""" & wb.FullName & """), null, true)," _
            & "フィルタ = Table.SelectRows(ソース, each ([Kind] = ""Sheet"" and [Item] <> ""統合"" and [Item] <> ""設定""))," _
            & "ヘッダ昇格 = Table.AddColumn(フィルタ, ""カスタム"", each Table.PromoteHeaders(Table.Skip([Data]," & n & "), [PromoteAllScalars=true]))," _
            & "他列削除 = Table.SelectColumns(ヘッダ昇格,{""カスタム"", ""Name""})," _
            & "Data展開 = Table.ExpandTableColumn(他列削除, ""カスタム"",{""品番"",""小計"", ""合計""})" _
            & "in  Data展開"

    Set qry = wb.Queries.Add(Name:=qryName, Formula:=f)

    Set tbl = ws.ListObjects.Add( _
            SourceType:=0, _
            Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & qryName, _
            Destination:=dst(1))

    With tbl.QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [" & qryName & "]")
        .Refresh BackgroundQuery:=False
    End With

    qry.Delete
    tbl.Unlist

 End Sub

（マナ） 2022/08/09(火) 19:17

↕では、使いませんでしたが、
こんな感じで、設定シートの情報は利用できます。

 Sub test()
    Dim 品番先頭 As String

    品番先頭 = Worksheets("設定").Range("C3").Value
    MsgBox Worksheets("Sh1").Range(品番先頭).Value

 End Sub

（マナ） 2022/08/09(火) 19:39

 マナさん
  19:17　のコードでできました！

 >なお設定シートの情報は利用していません
 なのですね…。
 19:39のコード勉強します

 >クエリの更新結果だけをコピペするのがよいと思います。
 もしかして結果の書式がPower Queryのデフォルトということでしょうか。

 ありがとうございました。

（葉月） 2022/08/10(水) 10:59

コメント返信：

[ 一覧(最新更新順) ]

[[20220808074628]] 『vba 各シートの品番欄と合計欄とシート名を転記』（葉月） ページの最後に飛ぶ

[[20220808074628]]　『vba 各シートの品番欄と合計欄とシート名を転記』（葉月）　ページの最後に飛ぶ