[[20130812140903]]　『セルに入力した名前のシートを作成』（ちょび助）　ページの最後に飛ぶ

『セルに入力した名前のシートを作成』（ちょび助）
Excel2010

 下記のサイトでシートで入力した文字をシート見出しに反映できる
 マクロが乗っていました。

 "名簿"シートに入力して、その名前を新規のシートの見出しとして
 作成をしたいと思っています。

 下記のマクロを使用すれば、新規のシートが出来てシート見出しも
 名簿に入力された名前が反映されます。

 これを名簿に名前を入力したら、原本のシートをコピーしてシート
 見出しの名前を変更するというマクロに変更したいのですが
 どうしたらよいでしょうか?

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

 http://pc.nikkeibp.co.jp/article/knowhow/20090811/1017747/

 Sub 連続シート挿入()
   For Each 対象セル In Selection
     Sheets.Add after:=ActiveSheet
     ActiveSheet.Name = 対象セル.Value
   Next 対象セル
 End Sub

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")
        For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            iFlag = 0
            For j = 1 To Sheets.Count
                If Sheets(j).Name = .Cells(i, "A").Value Then
                    iFlag = 1
                    Exit For
                End If
            Next j
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(i, "A").Value
            End If
        Next i
    End With
End Sub
(???)

???さんありがとうございます。

Sheets(Sheets.Count).Name = .Cells(i, "A").Valueで下記のメッセージのデバックが
表示されてしまいました。

エラーの内容は
実行時エラー '1004': アプリケーション定義またはオブジェクト定義のエラーです

どう回避したらよいでしょうか?

ちょび助

「名簿」シートは、A列1行目から全てシート名が並んでいる事を想定しています。
先頭が1行目でないのではないでしょうか。例えば3行目からがシート名の場合、
iのForループを3から始まるように変えてみてください。
（または、A列ではない？）
(???)

 ＞名簿に名前を入力したら
 →Worksheet_Changeイベント？？

 (HANA)

 名簿シートはA列(A5セル～)に名前を入力しています。

 受講生の名前を追加入力していきますので、その都度ワークシートを
 作成していきます。

 iのForループを変更しましたが1枚はワークシートができましたが
 2枚目はやっぱりデバックしてしまいました。

 ちょび助

手作業で、作られなかったシート名（名簿の名前の2番目）に変更してみてください。
シート名に使ってはいけない文字列が含まれていないでしょうか？
（おそらく人名なので、問題ないと思うのですが）

あと、このマクロはHANAさんのおっしゃるように、入力の度に動かしていますか？
ボタンでも配置して、ある程度名前を追加後に、1回実行するほうが良いと思います。
(???)

 ???さんやっぱりうまくいきません。(＠_＠;)

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")
        For i = 5 To .Cells(.Rows.Count, "A").End(xlUp).Row
            iFlag = 0
            For j = 5 To Sheets.Count
                If Sheets(j).Name = .Cells(5, "A").Value Then
                    iFlag = 5
                    Exit For
                End If
            Next j
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(5, "A").Value
            End If
        Next i
    End With
End Sub

 A5セル～入力していくのでマクロの内容は上記の内容であっていますでしょうか?

 ちょび助

 変えちゃいけないところまで変えてますよ。

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")

        '//N行目からA列の最終行まで繰り返す
        For i = 5 To .Cells(.Rows.Count, "A").End(xlUp).Row
            iFlag = 0

            '//シート1から順に名簿とすべてのシート名を比較し、同じ名前があるか調べ、有ったらiFlagを１にする
            For j = 1 To Sheets.Count
                If Sheets(j).Name = .Cells(i, "A").Value Then
                    iFlag = 1
                    Exit For
                End If
            Next j

            '//iFlagが0の時（即ちシート名が名簿と被らなかった場合）、シートを追加し、名簿の名前を付ける
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(i, "A").Value
            End If
        Next i
    End With
End Sub

 ×For j = 5 To Sheets.Count
 ×iFlag = 5
 ×If Sheets(j).Name = .Cells(5, "A").Value Then
 ×Sheets(Sheets.Count).Name = .Cells(5, "A").Value

 （稲葉）

 稲葉さんありがとうございます。

 名簿に追加したシートもちゃんと作成されるようになりました。

 …ですが残念なことにA列の名前が入っていない空白セルのところまで
 ワークシートを作ろうとしてデバックが表示されてしまいます。

 Sheets(Sheets.Count).Name = .Cells(i, "A").Value
 エラーの内容は 
 実行時エラー '1004': アプリケーション定義またはオブジェクト定義のエラーです

 どう回避したらよいでしょうか?

 ちょび助

 A列の一番↓のセルから
 Ctrl+↑
 でどこで止まるか確認してください。
 空白（に見える）セルで止まるなら、セルの削除を試みてください。
 （稲葉）

 稲葉さんありがとうございます。

 特にデータの入っている空白せるはありませんでした。

 ちょび助

稲葉さん、フォローいただき、ありがとうございます。助かります。
とりあえず今回は、名簿を変えずに、以下のマクロでいかがでしょうか。

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")
        For i = 5 To .Cells(5, "A").End(xlDown).Row
            iFlag = 0
            For j = 1 To Sheets.Count
                If Sheets(j).Name = .Cells(i, "A").Value Then
                    iFlag = 1
                    Exit For
                End If
            Next j
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(i, "A").Value
            End If
        Next i
    End With
End Sub
(???)

でもって、今度は途中で終わってしまう、というのであれば、以下。

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")
        For i = 5 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If .Cells(i, "A").Value <> "" Then
                iFlag = 0
                For j = 1 To Sheets.Count
                    If Sheets(j).Name = .Cells(i, "A").Value Then
                        iFlag = 1
                        Exit For
                    End If
                Next j
                If iFlag = 0 Then
                    Sheets("原本").Copy After:=Sheets(Sheets.Count)
                    Sheets(Sheets.Count).Name = .Cells(i, "A").Value
                End If
            End If
        Next i
    End With
End Sub
(???)

 後ろから失礼します。
＞名簿に名前を入力したら
 →Worksheet_Changeイベント　で書いてみました。あまり自信ないので、あくまで習作ということで。

 名簿シートのタブを右クリック→「コードの表示」　出てきた画面に次のを貼り付けます。
 Option Explicit

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim errflag As Boolean
    Dim r As Range
    Dim sh1 As Worksheet
    Set sh1 = Sheets("名簿")
    Set r = sh1.Range("A5", sh1.Range(("A") & sh1.Rows.Count))

    If Not Intersect(Target, r) Is Nothing Then          'TargetがＡ５～Ａ列の最後のセル（2003ならA65536）の範囲内なら
        If Len(Target) <> 0 Then                          '空白でなければ
            If IsObject(Evaluate("'" & Target & "'!A1")) Then    'Targetをシート名にしたらオブジェクトになっていれば
                MsgBox "シート:" & Target & "が既に存在します"
                Exit Sub
            End If
            With CreateObject("VBScript.RegExp")
                .Pattern = "[:|\\|/|\?|\*|\[|\]]"
                errflag = .test(Target)              'Targetにシート名使用禁止文字があるかどうか
                If errflag Then
                    MsgBox "コロン、円記号、疑問符、角かっこ、スラッシュ、アスタリスク　はシート名に使用できません"
                    Exit Sub
                End If
            End With

            On Error Resume Next
            Sheets("原本").Copy after:=Sheets(Sheets.Count)
            On Error GoTo 0
            If ActiveSheet.Name <> "名簿" Then
                ActiveSheet.Name = Target.Value
            Else
               Exit Sub
            End If
        Else
            Exit Sub
        End If
    End If
    Sheets("名簿").Select
End Sub

 ※名簿のA列全体をdeleteするとエラーになります。
 ※一度名前を入力して、ワークシートがコピーされたら、名前を消してもコピーしたシートは残ります。

 (usamiyu)

 ???さん・稲葉さん

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

 usamiyuさんもありがとうございます。

 ちょび助

 ???さんから教えていただいたマクロで問題なくワークシートを作成することが
 出来たのですが、ふただび質問させてください。

 フルネームでワークシートを作成した後に名前を名字だけにしてしまうと再度マクロを
 実行するとまた同じワークシートができてしまいます。
 例）ワークシートの名前“鈴木太郎”を鈴木にしてしまうと次にマクロを実行すると
“鈴木太郎”しーとが出来上がってしまう

 これを名簿シートに入力した名前を範囲指定ものだけを新規のワークシート（フルネーム）
 にするといった内容にできないでしょうか？

 現在???さんのマクロを参考に一部変更しています。

《???さんのマクロ》

 Sub 連続シート挿入()
    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("名簿")
        For i = 5 To .Cells(5, "A").End(xlDown).Row
            iFlag = 0
            For j = 1 To Sheets.Count
                If Sheets(j).Name = .Cells(i, "A").Value Then
                    iFlag = 1
                    Exit For
                End If
            Next j
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(i, "A").Value
            End If
        Next i
    End With
End Sub

《ちょび助のマクロ》

    Dim i As Long
    Dim j As Long
    Dim iFlag As Long

    With Sheets("累計")
        For i = 52 To .Cells(5, "A").End(xlDown).Row
            iFlag = 0
            For j = 1 To Sheets.Count
                If Sheets(j).Name = .Cells(i, "A").Value Then
                    iFlag = 1
                    Exit For
                End If
            Next j
            If iFlag = 0 Then
                Sheets("原本").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = .Cells(i, "A").Value

'シート見出しの名前をＢ2セルに反映させAgentIDは累計シートから反映

    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=RIGHT(CELL(""filename"",RC),LEN(CELL(""filename"",RC))-FIND(""]"",CELL(""filename"",RC)))"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],累計!R8C1:R64C2,2,0)"
    Range("A2:B2").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Application.CutCopyMode = False

            End If
        Next i
    End With

 かっこ悪いマクロですみません(＠_＠;)

 ちょび助

 フォローになってないフォロー
 選択範囲だけ対象にしました。
 これでいかがでしょう？

Sub ren2()

    Dim i As Long
    Dim j As Long
    Dim iFlag As Long
    Dim r As Range
    Dim x As String

    With Sheets("累計")
        If Intersect(Selection, .Range("A52:A" & .Cells(52, "A").End(xlDown).Row)) Is Nothing Then Exit Sub
    End With

    For Each r In Selection '選択範囲でループ
        iFlag = 0
        x = r.Value
        For j = 1 To Sheets.Count
            If Sheets(j).Name = x Then
                iFlag = 1
                Exit For
            End If
        Next j
        If iFlag = 0 Then
            Sheets("原本").Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = x
            With Sheets(x)
                'シート見出しの名前をＢ2セルに反映させAgentIDは累計シートから反映
                .Range("B2").FormulaR1C1 = "=RIGHT(CELL(""filename"",RC),LEN(CELL(""filename"",RC))-FIND(""]"",CELL(""filename"",RC)))"
                .Range("A2").FormulaR1C1 = "=VLOOKUP(RC[1],累計!R8C1:R64C2,2,0)"
                .Range("A2:B2") = .Range("A2:B2").Value
                Application.CutCopyMode = False
            End With
        End If
    Next r
End Sub
 （稲葉）

 説明中のシート名が「累計」になったり「名簿」になったり、ぶれていないでしょうか。
 （対象行も5行目以降だったり52行目以降だったり？）

 選択範囲を処理する方法は稲葉さんから提示されていますが、元のコードのシート名の部分は
   .Range("B2").FormulaR1C1 = "=RIGHT(CELL(""filename"",RC),LEN(CELL(""filename"",RC))-FIND(""]"",CELL(""filename"",RC)))"
   .Range("A2:B2") = .Range("A2:B2").Value
 は最初から
   .Range("B2").Value = .Cells(i, "A").Value
 でよさそうな・・・。
 (Mook)

 ここはマルチポストはOKの姿勢なんだけど、他掲示板に迷惑かけるのはお薦めしないので、
 是非あちらの掲示板にも解決した旨を書いておいたらいかがでしょう？
[[20130814125500]]

 稲葉さんありがとうございました。
 Mookさんのご指示のとおり内容がぶれていてすみませんでした。

 マクロは無事希望する結果で動いています。

 Mookさん掲示板の件早速報告をしておきます。

 ちょび助

 マルチポストの指摘をされたのは私ではなく、名無しの方なので念のため。

 いっていることはごもっともですが、学校の掲示板ではコメント書くときに署名を書くよう
 説明もあるのですけれどね。
https://www.excel.studio-kazu.jp/wiki/excelboard/
 (Mook)

コメント返信：

[ 一覧(最新更新順) ]

[[20130812140903]] 『セルに入力した名前のシートを作成』（ちょび助） ページの最後に飛ぶ

[[20130812140903]]　『セルに入力した名前のシートを作成』（ちょび助）　ページの最後に飛ぶ