[[20200615192929]]　『別シートへ項目ごとに転記』（みみ）　ページの最後に飛ぶ

『別シートへ項目ごとに転記』（みみ）

 以前にもご質問させていただきましたが、解決していないため再度質問させてください。
 下記コードは、B列の項目ごとにシートを作成するマクロとなります。
 VBについては素人となりますので、ネットから調べ引用していますが、
 （Sheet1）と同じ列・行の幅、またページレイアウトまで同じように別シートを
 作成するにはどうしたらいいかご教示いただけないでしょうか？
 シート数は、100を超えるので、1シートごとレイアウト変更を行うことは困難です。
 ご教示ください。
 あくまで素人なので質問不足もあるかもわかりませんが、よろしくお願いします。

Sub test1()

    Dim i As Long
    Dim lastRow As Long
    Dim mySh As Worksheet
    Dim myFlg As Boolean
    Dim myRow As Long
    Dim myKey As String
        lastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To lastRow
            '----振り分け先のシートが存在するか否かをチェック
            For Each mySh In Worksheets
                myFlg = False
                myKey = Worksheets("Sheet1").Range("B" & i).Value
                If mySh.Name = myKey Then
                    myFlg = True
                    mySh.Cells.Delete
                    Exit For
                End If
            Next mySh
            '----振り分け先のシートがなかったらシートを追加する
            If myFlg = False Then
                ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey
            End If
            '----列見出しをコピー&貼り付け
            Worksheets("Sheet1").Range("A1:Q1").Copy Worksheets(myKey).Range("A1")
        Next i
        '----データを転記する
        For i = 2 To lastRow
                myKey = Worksheets("Sheet1").Range("B" & i).Value
            If myKey <> "" Then
                myRow = Worksheets(myKey).Range("A" & Rows.Count).End(xlUp).Row + 1
                Worksheets("Sheet1").Range("A" & i & ":P" & i).Copy _
                    Worksheets(myKey).Range("A" & myRow & ":P" & myRow)
            End If
        Next i
End Sub

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

＞ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey

ここで、新規シートを追加していますが、Sheet1をコピーするようにしてはどうでしょうか。

（マナ） 2020/06/15(月) 20:15

 早速の回答ありがとうございます。
 できれば、コードの修正もご教示いただけたら助かります。
（みみ） 2020/06/15(月) 20:31

横からですが、シートをコピーする命令はマクロの記録で直ぐに調べることができますから、試してみてはどうですか？

シート名の変更は、

 Worksheets(Worksheets.Count)).Name = myKey

で可能でしょうし…

（もこな２） 2020/06/15(月) 21:16

 こんばんは！
単純にSheet1と同じシートを100個作るだけなら
↓このコードでもそうなりますね(^^;
後は、名前ですね。。。
それとシートを100個というのは頂けないですね。。。仕様を見直した方がいいと思います。
最近のパソコンはそんなことはないのでしょうけど、、メモリーを食うのですね。
まぁ、、、一例です。。。応用して頂けると助かります。。。

 Option Explicit
Sub Macro1()
Dim i As Long
For i = 1 To 100
    Sheets("Sheet1").Copy Before:=Sheets(2)
Next
End Sub
（SoulMan） 2020/06/15(月) 21:36

具体的なコードを示す前に余談なぞ。
気に入らなければ「■以下本題■」まで読み飛ばしてください。

＞以前にもご質問させていただきましたが、解決していない
前トピックは↓ですかね
[[20200601145018]]　『項目を指定し、シートに分割する』（みみ）

件のトピックをみると別に内容が変わってないようですし、別トピックにする必要なかったんじゃないですかね。
もちろん、トピックを変えてはダメとは言いませんが、それならそれで、ちゃんと元トピックの話を終わらせるのが筋ではないでしょうか？

過去ログを探すために、（みみ）というニックネームで調べてみたら、件のトピックのほかにも、回答者からのキャッチボールを返してないものがゴロゴロみつかるのですよね。。。

そうなると、どうせ回答をつけても、また放置するんだろうなんて思っちゃっても答えたくなくなったりします。
無論、そうは感じない回答者さんも大勢いらっしゃるでしょうから困ることはないと思いますが、たまには回答するほうのことも気遣ってほしいなぁなんて思った次第です。

■以下本題■

本トピックの質問については、実際にステップ実行で研究していただくとして、シートの存在チェックについて、提示された方法以外にも存在しないシートを取得しようとするとエラーが発生するのを利用する方法もありますよ。

それを踏まえて別案。

    Sub 別案()
        Dim SH As Worksheet
        Dim i As Long

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

        With Worksheets("Sheet1")
            For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row

                '▼オブジェクト変数「SH」をリセットしてから、シートをセットしようとしてみる
                Set SH = Nothing
                On Error Resume Next
                Set SH = Worksheets(.Cells(i, "B").Value)
                On Error GoTo 0

                '▼シートが存在せず、セットが失敗して初期値の「Nothing」のままになっているときだけ処理する
                If SH Is Nothing Then

                    '// コピーしてシートの末尾に挿入【★ここを研究】
                    Worksheets("Sheet1").Copy after:=Worksheets(Worksheets.Count)

                    '// シートの末尾（に挿入された）シートを変数にセット
                    Set SH = Worksheets(Worksheets.Count)
                    SH.Name = .Cells(i, "B").Value

                    '----コピーしたシートの見出し行以外をクリア
                    SH.UsedRange.Offset(1).ClearContents
                End If

                '▼無条件で処理する
                .Range("A" & i & ":P" & i).Copy SH.Range("A" & .Rows.Count).End(xlUp).Offset(1)
            Next i
        End With

    End Sub

（もこな２） 2020/06/15(月) 23:32

 （もこな２ ）さん
 ご意見をいただいたとおり、親切にご回答いただいているにも関わらず。、
 大変失礼をいたしました。

 今後は十分注意し、回答者の立場にたちたいと思います。

 ご回答いただいた内容ですが、やはり私の能力では、上手くいきませんでした。
 一から出直します。
 すいませんでした。
（みみ） 2020/06/16(火) 07:43

＞やはり私の能力では、上手くいきませんでした。
一応、私の環境でテストしたときは正常に動いていたので、どのように「上手くいかない」のか説明されるとアドバイスできることがあるかもしれません。

とりあえず考えられることとしては
・「Sheet1」というシートがない
・参照したセルの値が""だったorシート名に使えない文字が含まれていたために、シートの作成に失敗した
なんてことが思いつきますが、ステップ実行して自己検証はしているでしょうから、そんなことだったらすぐに気づけるので違いますよね？

まぁ↓のように仰ってますし、追加の情報がないとよくわからないので考えるのはこの辺にしておきます。
＞一から出直します。

ちなみに、結局ほかのトピックは放置するんでしょうか？
遅ればせながらでも結果を報告するのが、答えてくれた人への礼儀じゃないですかね・・・

（もこな２） 2020/06/16(火) 22:14

コメント返信：

[ 一覧(最新更新順) ]

[[20200615192929]] 『別シートへ項目ごとに転記』（みみ） ページの最後に飛ぶ

[[20200615192929]]　『別シートへ項目ごとに転記』（みみ）　ページの最後に飛ぶ