[[20210503222756]]　『複数のシートのデータを一つにまとめたい(他サイメx（ギラくん）　ページの最後に飛ぶ

『複数のシートのデータを一つにまとめたい(他サイトを参考にしてます)』（ギラくん）

すいません
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_data_matome.html
を参考に　複数のシートのデータを一つにまとめるマクロを作って動くのは動いたのですが
シート２以降のシートもa1からまとめたいのですがどうすればよろしいでしょうか
また各シートのデータも４０行目まで転記(書き方が適切でなければすいません)したいのですがどうすればよろしいでしょうか
よろしくおねがいします

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

現在のコードを示して下さい。

（γ） 2021/05/03(月) 22:45

コメントありがとうございます
さっそくですが
sub sh_check()
　Dim newSh As String
　Dim Sh As Worksheet, myFlag As Boolean
　　newSh = "全データ"　'---まとめ用のシート名です
　　myFlag = False　'---まとめ用のシートが有ったら True /無かったら False にするフラッグです
　　For Each Sh In ThisWorkbook.Worksheets
　　　　If Sh.Name = newSh Then
　　　　　　myFlag = True
　　　　　　'----全データシートのデータをクリアし、先頭へ移動します
　　　　　　Worksheets(newSh).Cells.ClearContents
　　　　　　Worksheets(newSh).Move before:=Sheets(1)
　　　　　　Exit For
　　　　End If
　　Next Sh
　　'----全データシートを先頭へ追加します
　　If myFlag = False Then
　　　　ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
　　End If
End Sub
と
Sub matome()
　Dim i As Integer
　Dim lRow As Long, lCol As Long, lRow2 As Long
　　Application.ScreenUpdating = False
　　'----全データシートの有無をチェックします
　　sh_check
　　'----列見出しをコピーします
　　Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　lRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　　　'----シートのデータが2行以上の場合にコピーします
　　　　　　If lRow >= 2 Then
　　　　　　　　lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　　　　.Activate
　　　　　　　　.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
　　　　　　End If
　　　　End With
　　Next i
　　Worksheets(1).Activate
　　Range("A1").Select
　　Application.ScreenUpdating = True
End Sub
です
２つないと動かないですよろしくおねがいします

（ギラくん） 2021/05/03(月) 22:50

「シート２以降のシート」を纏めシートにコピーペイストしているところはどこですか？
その意味を理解していますか？
説明してもらえますか？

（γ） 2021/05/03(月) 22:59

漢字が難しくてなんて読むかがわかりません

（ギラくん） 2021/05/03(月) 23:02

纏め＝（まと）め　ですね。

（もこな２） 2021/05/03(月) 23:11

■はじめに
γさんとの会話が進んでいるとおもいますので、そちらが終わってからお読み下さい。

■１
VBAの世界では、基本的にブック、シートやセルなど（オブジェクトといいます）を明示すれば、いちいち選択したり、アクティブにしたりする必要はありません。

■２
「標準モジュール」で「Range("A1")」のような書き方をした場合、「ActiveSheet.Range("A1")」のようにアクティブシートを指定したものとして扱われます。
したがって、複数のシートやブックを相手にするようなったら、想定外のシートやブックを対象にしないためにも、１と併せて対象のオブジェクトは明示したほうがよいとおもいます。

■３
ネットで見かけたり、質問掲示板で回答のあったコードを眺めているだけでは、なかなか理解しにくいとおもいますので、【ステップ実行】により1行ずつ実行して動きを確認したり、知らない命令についてネット検索したりするのが重要だとおもいます。
また、ステップ実行は自分で作ったコードがちゃんと動くのかの検証にも有用ですから、知っておいて損はないとおもいます。
したがって、【ステップ実行】をご存じなければ↓を読んでみて下さい。

 【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html

また、以下も知っておいて損は無いと思います。

 【イミディエイトウィンドウ】
https://www.239-programing.com/excel-vba/basic/basic024.html
https://excel-ubara.com/excelvba1/EXCELVBA486.html

 【ローカルウィンドウ】
https://excel-ubara.com/excelvba4/EXCEL266.html
http://excelvba.pc-users.net/fol8/8_2.html

 【ブレークポイント】
https://www.239-programing.com/excel-vba/basic/basic022.html
https://www.tipsfound.com/vba/01010

■４
シートの有無について全シートを巡回して、1つずつチェックするのもありですが、実はもうちょっと簡単な方法があります。

    Sub 研究用01()
        Dim MySH As Worksheet

        On Error Resume Next
        Set MySH = ThisWorkbook.Worksheets("存在しない")
        On Error GoTo 0

        If MySH Is Nothing Then
            MsgBox "「存在しない」シートはありません"
        Else
            MsgBox "「存在しない」シートは存在します"
        End If
    End Sub

■５
ということを踏まえて、提示のコードを整理すると↓のようになりますよね。

    Sub 整理()
        Dim dstSH As Worksheet

        On Error Resume Next
        Set dstSH = ThisWorkbook.Worksheets("全データ")
        On Error GoTo 0

        If MySH Is Nothing Then
            ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1)).Name = "全データ"
            Set dstSH = ThisWorkbook.Worksheets("全データ")
        Else
            MySH.Cells.ClearContents
            MySH.Move before:=ThisWorkbook.Sheets(1)
        End If

        '----列見出しをコピーします
        Worksheets(2).Rows(1).Copy MySH.Rows(1)

        For i = 2 To ThisWorkbook.Worksheets.Count
            With ThisWorkbook.Worksheets(i)
                '----シートのデータが2行以上の場合にコピーします
                If .Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
                    '★【2】行目～A列の最終行までをコピー対象にしている★
                    .Rows("2:" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy dstSH.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                End If
            End With
        Next i

    End Sub

＞シート２以降のシートもa1からまとめたいのですがどうすればよろしいでしょうか
さて、【1】行目からコピーするにはどこをいじれば良いでしょうか？

（もこな２） 2021/05/04(火) 11:30

失礼コードに一部コードに誤りがありました。

×　MySH
○　dstSH

（もこな２） 2021/05/04(火) 14:33

もこな２さんありがとうございます
纒めという字初めてみました　勉強になりました(笑)
それは置いといて
γさん

「シート２以降のシート」を纏めシートにコピーペイストしているところはどこですか？その意味を理解していますか？
説明してもらえますか？
シート２以降のシートは「全データ］という名前のシートにコピーペーストしてると理解しています

もこな２さん

  .Rows("2:" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy dstSH.Cells(Rows.Count, "A").End(xlUp).Offset(1)
の  .Rows("2:" &・・・・・・・・・・・を1にすればいいとおもいます
また同様に列はCells(Rows.Count, "A")を変えればとおもいます
まちがえてたらすいません
（ギラくん） 2021/05/04(火) 19:26

＞～とおもいます。
では実際に【ご自身】で検証してみましょう。

その上でエラーが出るならどの箇所で何というエラーが出たのか、エラーにならないが想定と違った動きになるなら、××になると思ったが△△となってしまう。のように提示してください。

（もこな２） 2021/05/04(火) 19:45

わかりました明日れんらくします
（ギラくん） 2021/05/04(火) 20:45

まず、どこで実行しているかですが、
.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
Withがあるので正確に書くと、
Worksheets(i).Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
ですね。

　
Cellsのシート指定が無い点は、後述(*)するとして
元のシートの、どのセル範囲をコピーしていますか？
＞シート２以降のシートは「全データ］という名前のシートにコピーペーストしてると理解しています
という回答はポイントをはずしています。
それを読み解いて欲しかったのです。
　
Range(Cells(2, 1), Cells(lRow, lCol))
というセル範囲の指定方法はご存じなかったですか？
この際、よく学習してください。
　
コードのひとつひとつをないがしろにしては理解が進みません。
　
なお、すでに他の回答者さんから回答をもらっていますので、
解決済みですが、コメントを頂いていたので、それにお答えしたものです。

 以下は枝葉末節（というか、もっと先で気を着けて欲しい点）ですので、
 スキップして頂いて構いません。
 (*)
 中にあるCells(...)はシート指定がないので、その時のアクティブシートと見なされます。
 .Activate
 とそのシートをアクティブにすることで避けていますが、
 シートの選択は、パフォーマンスの悪化につながりますから、普通は避けます。
 (a)
 .Range(.Cells(2, 1), .Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
 とドットを頭につけるか、
 (b)
 .Cells(2, 1).Resize(lRow-1,lCol).Copy Worksheets(1).Cells(lRow2, 1)
 とするか、いずれかが良いでしょう。

（γ） 2021/05/04(火) 21:10

もこな２さんおそくなりました

                    .Rows("2:" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy dstSH.Cells(Rows.Count, "A").End(xlUp).Offset(1)
を
                    .Rows("1:" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy dstSH.Cells(Rows.Count, "A").End(xlUp).Offset(1)
にしたところ
できました
ただ　
・・・・Cells(Rows.Count, "A").End(xlUp).Offset(1)
を変えてみたところ
コピー領域と貼り付け領域のサイズが違うため、これをここに貼り付ける事ができません
と出てしまいました

多分統合されたセルがあるためと思うのですが　これを回避してシート全体をコピーする方法はありますか

（ギラくん） 2021/05/05(水) 18:22

＞多分統合されたセルがあるためと思うのですが
たぶん違います。

【何】を【どこ】へ貼り付けることになっているのかよく検証してみてください。

（もこな２） 2021/05/05(水) 18:45

コメントありがとうございます
どうやって検証すればよろしいでしょうか
色々とすいません
（ギラくん） 2021/05/05(水) 20:12

＞どうやって検証すればよろしいでしょうか
■３は読みましたか？

読んだのであれば
変数「i」には何が入っいたのですか？

コピー対象のセルは、【どの】シートの、どこ（セル範囲）になってましたか？
また、貼り付け先のセルは、【どの】シートの、どこ（セル範囲）になってましたか？

踏まえたうえで、その貼り付け先の範囲は貼り付けることができる範囲になっていましたか？

（もこな２） 2021/05/05(水) 22:32

コメントありがとうございます
少し考えてみます
来週になるかもしれませんがコメントします
（ギラくん） 2021/05/05(水) 22:58

コメントおそくなりました

変数「i」には何が入っいたのですか？数字で最終的に２３になりました
コピー対象のセルは２枚目以降のシートの２～１９行目になってました　
そして貼り付け先は貼り付けたすぐ下のセルに貼り付けるようになってました

（ギラくん） 2021/05/06(木) 20:27

■６
少し落ち着いてください。
エラーが起こった時の状況をちゃんと分析できているのか確認しています。

↓ですから、変数「i」の部分には【何番目】のシートなのかという情報（インデックス番号といいます）が入るわけですよね、

 For i = 2 To ThisWorkbook.Worksheets.Count

つまり、エラーが起こった時の「i」を調べれば、何番目のシートを対象にしているときにエラーになったのかが分かります。

なので、【どの】シートなのか確認するように言ったわけです。

■７
つぎに、私が示したコードでは、↓のように.Rowsを使っていますから、

  .Rows("2:" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
  ^^^^^^

例えば↓のようであれば、2～19行目の【行全体】をコピーしなさいという命令になります。
.Rows("2:19").Copy

さて、【行全体】をコピーした場合、貼り付けられるのは、同じく行全体か一番左端の列（A列）に限られます。（じゃないとはみ出しちゃいますよね）

したがって、どのように変えたかは示されていませんでしたが、おそらくA列以外にしちゃってエラーが出たのではないかと推測したため「違う」とコメントを付けた次第です。

■８
なお、いちいち最終列をもとめるのが面倒なので行全体にしてしまいましたが、元のコードのようにちゃんと列番号を調べるのも悪くないとおもいます。

    For i = 2 To Worksheets.Count
        With Worksheets(i)
            lRow = .Cells(Rows.Count, 1).End(xlUp).Row
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '←★ココ
            '----シートのデータが2行以上の場合にコピーします
            If lRow >= 2 Then
                .Range("A1", .Cells(lRow, lCol)).Copy Worksheets("全データ").Cells(Worksheets("全データ").Rows.Count, "A").End(xlUp).Offset(1)
            End If
        End With
    Next i

こちらであれば、Ａ列じゃなくても（限度はありますが）貼り付けることができるでしょう。

■９
このほか気になるのは「結合セル」があるといっていることです。
場合によっては最終行がうまく取得できないかもしれません。
念のためこちらも、確認されたほうがよいでしょう。
（どこが結合されているのかの情報がなかったので原因が特定できず、"たぶん"違うとコメントしました）

（もこな２） 2021/05/07(金) 00:21

コメントありがとうございます
結合セルの情報(どこが結合セルかがわからない)のでどこが結合セルかが確認できる方法はありますか

（ギラくん） 2021/05/07(金) 19:22

＞結合セルの情報(どこが結合セルかがわからない)のでどこが結合セルかが確認できる方法はありますか
質問が理解できません。

＞多分統合されたセルがあるためと思うのですが
とおっしゃっているのでご自身でどこが結合されているのかご存知なのでは？

（もこな２） 2021/05/07(金) 19:38

じつをいうと　私は各支店のデータをまとめてるだけでどこが統合されたセルか各支店ごとフォーマットが違うのでわからないのです
説明がなくすいません

（ギラくん） 2021/05/07(金) 19:53

すいません少しどこが結合セルか探してみます
（ギラくん） 2021/05/07(金) 20:03

＞すいません少しどこが結合セルか探してみます
それが、エラーの原因とは限りませんから、先に目の前のエラーに向き合ったほうがよいのでは？

＞どこが統合されたセルか各支店ごとフォーマットが違うのでわからないのです
少なくとも、いまは同じブックのなかではなしをしているのですよね？

そして、どのシートのどのセル範囲をどこに貼り付けしようとしたらエラーになるかもわかってるんですよね？
そんなの、コピー元のセル範囲と貼り付け先のセル（範囲）を目視などでチェックするだけですよね？

もう一度確認ですが、
コピー元はどのシート（何番目）なのですか？
そして、どのセルを対象にしているのですか？

また、貼付先は、「まとめ」シートのどのセルですか？
（特にrowsをコピペするなら、どの【列】に貼付しようとしてるんですか？
）

（もこな２） 2021/05/07(金) 20:25

コメントありがとうございます
http://excel.resocia.jp/report/2386/　　で結合セルを検索したところ
VとW列の２２～２６
YとZ列の２２～２７
が結合されてました
ご迷惑おかけしました
（ギラくん） 2021/05/07(金) 20:35

 単に1行目からコピーすると言うことなら、
 こんなのでいいんじゃないですか？　sh_checkも少し修正あり。

 Private Sub sh_check()
   Dim newSh As String
   Dim Sh As Worksheet, myFlag As Boolean
     newSh = "全データ"  '---まとめ用のシート名です
     myFlag = False  '---まとめ用のシートが有ったら True /無かったら False にするフラッグです
     For Each Sh In ThisWorkbook.Worksheets
         If Sh.Name = newSh Then
             myFlag = True
             '----全データシートのデータをクリアし、先頭へ移動します
             Worksheets(newSh).Cells.Clear　’ClearContentsではない。(結合セル対策）
             Worksheets(newSh).Move before:=Sheets(1)
             Exit For
         End If
     Next Sh
     '----全データシートを先頭へ追加します
     If myFlag = False Then
         ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
     End If
 End Sub

 Sub matome()
     Dim i As Integer
     Dim stRW As Long

     Application.ScreenUpdating = False

     sh_check '----全データシートの有無をチェックします

     stRW = 1

     For i = 2 To Worksheets.Count
         With Worksheets(i)
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy Worksheets(1).Cells(stRW, 1)
                 stRW = stRW + .Rows.Count
             End With
         End With
     Next i

     Worksheets(1).Activate
     Range("A1").Select

     Application.ScreenUpdating = True
 End Sub

（半平太） 2021/05/07(金) 20:48

■10
＞VとW列の２２～２６
＞YとZ列の２２～２７
＞が結合されてました

であれば、↓のどちらにも影響ないですね。

 lRow = .Cells(Rows.Count, 1).End(xlUp).Row
 Worksheets("全データ").Cells(Worksheets("全データ").Rows.Count, "A").End(xlUp).Offset(1)

やはり、貼り付け先をB列以降にしてしまったとかではないですか？
（どのように変えたのか問いかけましたがお返事はいただけてないですが・・・）

ちなみに、実はxlsx形式のブックから、xls形式のブックに貼り付けようとしているとかであれば列数が違うので、そのエラーが出るでしょうけど、今回は同じブックの話ですよね？
（こちらも問いかけしたはずですが、明確な答えは頂けてないですね）

いずれにせよ「■８」でコメントしたとおり、行全体作戦はやめたほうが良いと思います。

あと考えられることとしては、「ClearContents」だと【結合セル】（書式）はクリアされないので、それが影響してるということはないですか？
（下記のテストをしているときにふと思い至ったのですが、すでに半平太さんが指摘されてました・・・車輪の再発明ors）

■11
すでに、確認すべきポイントは述べたと思うので、そちらは適宜確認していただくとして、別案を提示しておきます。
（同じデータは用意できないですが、こちらで用意した適当なデータで動くことはチェック済です）
（チェック環境：＜使用 Excel：office365、使用 OS：Windows10 ＞）

    Option Explicit
    Sub 別案()
        Dim dstRNG As Range
        Dim i As Long, lRow As Long, lCol As Long

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

        '▼出力先のセルを覚えようとする
        On Error Resume Next
        Set dstRNG = ThisWorkbook.Worksheets("全データ").Range("A1")
        On Error GoTo 0

        '▼（対象シートが無くて）出力先のセルを覚えるのに失敗したら
        If dstRNG Is Nothing Then
            '// 自ブックの１番目に新規シートを追加して、名前を「全データ」にして、出力先セルを覚える
            With ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1))
                .Name = "全データ"
                Set dstRNG = .Range("A1")
            End With
        Else
            '// 覚えた出力先の親（つまり、「全データ」シート）をクリアして、１番目のシートになるように移動させる
            dstRNG.Parent.Cells.Clear 'ClearContentsでは結合セル（書式）がクリア出来ない
            dstRNG.Parent.Move before:=ThisWorkbook.Sheets(1)
        End If

        '▼２番目のシートから繰り返し処理
        For i = 2 To ThisWorkbook.Worksheets.Count
            '▼○番目のシートをWithステートメントの対象にする
            With ThisWorkbook.Worksheets(i)
                lRow = .Cells(Rows.Count, 1).End(xlUp).Row
                lCol = .Cells(1, Columns.Count).End(xlToLeft).Column

                '▼○番目のシートのA1～lRow行、lCol列のセルまで（つまりコピー対象の【セル範囲】）をWithステートメントの対象にする
                With .Range("A1", .Cells(lRow, lCol))

                    '// コピー対象のセル範囲を出力先セルの【１列右】に貼り付ける
                    .Copy dstRNG.Offset(0, 1)

                    '// 出力先セル（単一セル）をコピー対象のセル範囲の行数分拡張して、コピー対象が属するシート名を書き込む
                    dstRNG.Resize(.Rows.Count).Value = .Parent.Name

                    '// 次の処理のため、【出力先セル】をコピーしたセル範囲の行数分下にずらす
                    Set dstRNG = dstRNG.Offset(.Rows.Count)
                End With
            End With
        Next i
    End Sub

おそらく、見慣れない命令があるとおもうので、1つずつネット検索して調べてみてください。
それでもわからないことがあれば、具体的に聞いていただければ、私がわかる範囲でお答えします。

他にコメントされたい方も、いらっしゃるようなのでそれまではＲＯＭに戻ります。
（といいつつ、我慢できなかったらコメントしちゃいますが）

（もこな２） 2021/05/08(土) 15:19

半平太さんコメントありがとうございます
無事できました　ですが一部関数を使ってるため貼り付け先で#N/Aになります
値のコピーで解決すると思うのですが
もこな２さん
色々とすいません
Worksheets("全データ").Cells(Worksheets("全データ").Rows.Count, "A").End(xlUp).Offset(1)
のRows.Count, "A"
を変えたところエラーになりました
（ギラくん） 2021/05/09(日) 19:49

 ＞値のコピーで解決すると思うのですが

 ２行に分ける

 ＞   .Cells.Copy Worksheets(1).Cells(stRW, 1)
 　　　　↓
      .Cells.Copy
      Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats

（半平太） 2021/05/09(日) 20:35

できました
ちなみにA～D列までを普通にコピーペースト(塗りつぶしセルがあるため)
それ以降の列を値のコピーにできませんか
半平太さん色々とすいません
（ギラくん） 2021/05/09(日) 21:06

 ちょっと分かりません。

 他の回答者のレスをお待ちください。m(__)m

（半平太） 2021/05/09(日) 21:26

＞ちなみにA～D列までを普通にコピーペースト(塗りつぶしセルがあるため)
値貼付したあと、そのまま書式も貼り付けたらどうですか？
または、値貼付けしたあと、A～D列だけコピーして書式を貼り付けるか

（もこな２） 2021/05/09(日) 21:43

もこな２さん色々とありがとうございます
値貼付けしたあと、A～D列だけコピーして書式を貼り付ける場合どういう構文をかけばいいでしょうか
（ギラくん） 2021/05/09(日) 21:50

＞値貼付けしたあと、A～D列だけコピーして書式を貼り付ける場合どういう構文をかけばいいでしょうか
今のコードどうなってますか？全体を示してみてください。
（理解できていれば、そのような質問にならないとおもうんですが・・・）

（もこな２） 2021/05/09(日) 22:08

コメントありがとうございます半平太さんのコードで

 Private Sub sh_check()
   Dim newSh As String
   Dim Sh As Worksheet, myFlag As Boolean
     newSh = "全データ"  '---まとめ用のシート名です
     myFlag = False  '---まとめ用のシートが有ったら True /無かったら False にするフラッグです
     For Each Sh In ThisWorkbook.Worksheets
         If Sh.Name = newSh Then
             myFlag = True
             '----全データシートのデータをクリアし、先頭へ移動します
             Worksheets(newSh).Cells.Clear  'ClearContentsではない。(結合セル対策）
             Worksheets(newSh).Move before:=Sheets(1)
             Exit For
         End If
     Next Sh
     '----全データシートを先頭へ追加します
     If myFlag = False Then
         ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
     End If
 End Sub

 Sub まとめ()
     Dim i As Integer
     Dim stRW As Long

     Application.ScreenUpdating = False

     sh_check '----全データシートの有無をチェックします

     stRW = 1

     For i = 2 To Worksheets.Count
         With Worksheets(i)
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy
                  Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats

stRW = stRW + .Rows.Count

             End With
         End With
     Next i

     Worksheets(1).Activate
     Range("A1").Select

     Application.ScreenUpdating = True
 End Sub

です
色々とすいませんがよろしくおねがいします
（ギラくん） 2021/05/09(日) 22:15

繰り返しになりますが↓が理解できていれば、詰まるとも思えないのですが理解できてますか？
（どのように理解してますか？）

 Application.Range(.Cells(1, 1), .UsedRange).Copy
 Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats

（もこな２） 2021/05/09(日) 23:20

反応がなくなっちゃいましたが、研究用として別案改を置いておきます。

    Option Explicit
    Sub 別案_改()
        Dim dstRNG As Range
        Dim i As Long, lRow As Long, lCol As Long
        Stop 'ブレークポイントの代わり

        On Error Resume Next
        Set dstRNG = ThisWorkbook.Worksheets("全データ").Range("A1")
        On Error GoTo 0

        If dstRNG Is Nothing Then
            With ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets(1))
                .Name = "全データ"
                Set dstRNG = .Range("A1")
            End With
        Else
            dstRNG.Parent.Cells.Clear 'ClearContentsでは結合セル（書式）がクリア出来ない
            dstRNG.Parent.Move before:=ThisWorkbook.Sheets(1)
        End If

        For i = 2 To ThisWorkbook.Worksheets.Count
            With ThisWorkbook.Worksheets(i)
                lRow = .Cells(Rows.Count, 1).End(xlUp).Row
                lCol = .Cells(1, Columns.Count).End(xlToLeft).Column

                '▼コピーして値のみ貼付け
                .Range("A1", .Cells(lRow, lCol)).Copy
                dstRNG.Offset(, 1).PasteSpecial Paste:=xlPasteValues

                '▼コピーして書式のみ貼付け
                .Range("A1", .Cells(lRow, "D")).Copy
                dstRNG.Offset(, 1).PasteSpecial Paste:=xlPasteFormats

                dstRNG.Resize(lRow).Value = .Name
                Set dstRNG = dstRNG.Offset(lRow)
            End With
        Next i
    End Sub

（もこな２） 2021/05/10(月) 07:44

すいません朝早くて寝てました

それで色々調べて

 Private Sub sh_check()
   Dim newSh As String
   Dim Sh As Worksheet, myFlag As Boolean
     newSh = "全データ"  '---まとめ用のシート名です
     myFlag = False  '---まとめ用のシートが有ったら True /無かったら False にするフラッグです
     For Each Sh In ThisWorkbook.Worksheets
         If Sh.Name = newSh Then
             myFlag = True
             '----全データシートのデータをクリアし、先頭へ移動します
             Worksheets(newSh).Cells.Clear  'ClearContentsではない。(結合セル対策）
             Worksheets(newSh).Move before:=Sheets(1)
             Exit For
         End If
     Next Sh
     '----全データシートを先頭へ追加します
     If myFlag = False Then
         ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
     End If
 End Sub

 Sub まとめ改()
     Dim i As Integer
     Dim stRW As Long

     Application.ScreenUpdating = False

     sh_check '----全データシートの有無をチェックします

     stRW = 1

     For i = 2 To Worksheets.Count
         With Worksheets(i)
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy
                  Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy
                  Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteFormats

stRW = stRW + .Rows.Count

             End With
         End With
     Next i

     Worksheets(1).Activate
     Range("A1").Select

     Application.ScreenUpdating = True
 End Sub

として試したところ　Nextに対応するForがありませんと出てしまいます

（ギラくん） 2021/05/10(月) 20:20

Sub まとめ改()

     Dim i As Integer
     Dim stRW As Long
     Application.ScreenUpdating = False
     sh_check '----全データシートの有無をチェックします
     stRW = 1
     For i = 2 To Worksheets.Count
         With Worksheets(i)
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy
                  Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats
             End With '★ここ★
             With Application.Range(.Cells(1, 1), .UsedRange)
                 .Cells.Copy
                  Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteFormats
                  stRW = stRW + .Rows.Count
             End With
         End With
     Next i
     Worksheets(1).Activate
     Range("A1").Select
     Application.ScreenUpdating = True
 End Sub

（もこな２） 2021/05/10(月) 20:55

ちなみに↓を２回繰り返す必要も感じないので

 Application.Range(Worksheets(i).Cells(1, 1), Worksheets(i).UsedRange).Copy

「値貼付したあと、そのまま書式も貼り付けたらどうですか？」といった通り

 Application.Range(Worksheets(i).Cells(1, 1), Worksheets(i).UsedRange).Copy
 Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteValuesAndNumberFormats
 Worksheets(1).Cells(stRW, 1).PasteSpecial xlPasteFormats

でいいんじゃないかと思うんですがね・・・

（もこな２） 2021/05/10(月) 21:04

もこな２さん色々ありがとうございます
ためしてみます

（ギラくん） 2021/05/10(月) 21:39

ありがとうございますできました
もこな２さん色々ありがとうございました
（ギラくん） 2021/05/11(火) 19:58

コメント返信：

[ 一覧(最新更新順) ]

[[20210503222756]] 『複数のシートのデータを一つにまとめたい(他サイメx（ギラくん） ページの最後に飛ぶ

[[20210503222756]]　『複数のシートのデータを一つにまとめたい(他サイメx（ギラくん）　ページの最後に飛ぶ