VBA セル値からシート検索&作成の条件分岐

Question

前提・実現したいこと

ﾘｽﾄ表ｼｰﾄのｼｰﾄﾊﾟﾀｰﾝ(A7以降)行毎に、ｼｰﾄを作成して対象ｼｰﾄ内にｵｰﾄｼｪｲﾌﾟを作成
させたいです。
＜条件＞
・作成ｼｰﾄはｶﾗｵｹｼｰﾄをｺﾋﾟｰして、ｼｰﾄ名をｼｰﾄﾊﾟﾀｰﾝ名に変更
・ｼｰﾄﾊﾟﾀｰﾝ種類は3種類(正面2、側面4、平面6)
・同一ｼｰﾄがある場合は、ｼｰﾄを作成せずに同一ｼｰﾄへｵｰﾄｼｪｲﾌﾟのみ作成
例.添付画像を実行した場合、8、10、12行はｼｰﾄは作成されず、対象ｼｰﾄへｵｰﾄｼｪｲﾌﾟのみ作成

Sub シート作成andオートシェイプ作成()
    Dim i As Integer   '行カウンタ
    Dim k As Integer   '数量カウンタ
    Dim o As Long      'シートカウンタ
    Dim list As Worksheet 'リスト表
    Dim Tl As Worksheet 'カラオケシート
    Dim zukei As Shape '図形
    Set list = Worksheets("リスト表")
    Set Tl = Worksheets("カラオケ")

    lastR = list.Cells(Rows.Count, "B").End(xlUp).Row 'ｼｰﾄﾘｽﾄ B列のｾﾙ入力済最終行を定義
    lastC = list.Cells(2, Columns.Count).End(xlToLeft).Column 'ｼｰﾄﾘｽﾄ B列のｾﾙ入力済最終行を定義

    For i = 7 To lastR    '7行目から1行ずつ処理
    
     For o = ActiveSheet.Index + 1 To Sheets.Count  '同一ｼｰﾄ検索
      If Sheets(o).Name Like Cells(i, 1).Value Then
           X = Cells(i, 3).Value '横
           Y = Cells(i, 4).Value ' 縦
           Z = Cells(i, 5).Value ' 品名
           kazu = ActiveSheet.Cells(i, 6)
           iro = ActiveSheet.Cells(i, 7)
           For k = 1 To kazu

           Set zukei = Shapes _
           .AddShape(msoShapeRectangle, 800, 30, X * 1.95, Y * 1.95)  '正面2ｼｰﾄへ図形作成
                                                  
           With zukei
           .TextFrame.Characters.Text = X & "×" & Y & vbCrLf & Z '図形へテキスト入力
           .TextFrame.Characters.Font.Size = 15                  'テキスト文字フォント変更
           .TextFrame.Characters.Font.ColorIndex = 1             'テキスト文字色変更
           .TextFrame.HorizontalAlignment = xlHAlignCenter       'テキスト文字水平中央
           .TextFrame.VerticalAlignment = xlVAlignCenter         'テキスト文字垂直中央
           End With
 
           Next k
                   
     Else
     Tl.Copy after:=Worksheets(Worksheets.Count)
     ActiveSheet.Name = list.Cells(i, 1).Value
    
     End If
   
     Next o

    Next i
   
    End Sub

試したこと

・ｼｰﾄ名を重複させず、作成しようと試みたのですができませんでした。
・構文も分かりませんでした。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[meg_]

「ActiveSheet」は操作によって変わってしまうので、あまり使わない方が良いかと思います。
「For o = ActiveSheet.Index + 1 To Sheets.Count」ここでの使用は危険な気がしますが。。

[jabe]

アドバイスありがとうございます。

Answer 1

自分が作るなら下記のような方針で実装します。

シートの存在チェックは別関数にする。
ついでに、存在していない場合は、その関数内でシートをコピー追加する。
関数の戻り値でそのシートを返す。

存在チェックはループで回すのも一つの方法だが、とりあえず取得してみてエラーなら存在しないと判断するという方法だとシンプルになる。

ということで、この方針で作成したものが下記です。

Option Explicit

Sub シート作成andオートシェイプ作成()
    Dim list As Worksheet 'リスト表
    Set list = Worksheets("リスト表")
    Dim Template As Worksheet
    Set Template = Worksheets("カラオケ")
    
    Dim lastR As Long
    lastR = list.Cells(Rows.Count, "B").End(xlUp).Row 'ｼｰﾄﾘｽﾄ B列のｾﾙ入力済最終行を定義
    Dim i As Long, j As Long
    For i = 7 To lastR    '7行目から1行ずつ処理
        
        Dim x As Long, y As Long, z As String, kazu As Long
        x = list.Cells(i, 3).Value '横
        y = list.Cells(i, 4).Value ' 縦
        z = list.Cells(i, 5).Value ' 品名
        kazu = list.Cells(i, 6)
        
        Dim aWS As Worksheet '追加シート
        Set aWS = CopySheet(list.Cells(i, 1).Value, Template)
        For j = 1 To kazu
            With aWS.Shapes _
                 .AddShape(msoShapeRectangle, 800, 30, x * 1.95, y * 1.95)  '正面2ｼｰﾄへ図形作成
                .TextFrame.Characters.Text = x & "×" & y & vbCrLf & z '図形へテキスト入力
                .TextFrame.Characters.Font.Size = 15                  'テキスト文字フォント変更
                .TextFrame.Characters.Font.ColorIndex = 1             'テキスト文字色変更
                .TextFrame.HorizontalAlignment = xlHAlignCenter       'テキスト文字水平中央
                .TextFrame.VerticalAlignment = xlVAlignCenter         'テキスト文字垂直中央
            End With
        Next j
    Next i

End Sub

'指定した名前のワークシートを取得
'存在しなければ、TemplateSheetをコピーして名前変更して取得
Private Function CopySheet(SheetName As String, TemplateSheet As Worksheet) As Worksheet
    On Error Resume Next
    Set CopySheet = Worksheets(SheetName)
    On Error GoTo 0
    If CopySheet Is Nothing Then
        TemplateSheet.Copy after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = SheetName
        Set CopySheet = ActiveSheet
    End If
End Function

Comments

[jabe]

コード作成ありがとうございます。
狙いどうりの動作になりました。
functionの意味を理解出来ていませんでしたので、こちらのｺｰﾄﾞを解読出来る様に勉強させていただきます。

[jabe]

すいません教えてください。
On Error Resume Next
On Error GoTo 0
↑ｴﾗｰをｽﾙｰする構文がある理由は何になるのでしょうか？

[jabe]

もう一点教えてください。
ｼｰﾄ検索して有り無し判断のif文ですが、copysheet変数の中身が有るか無いかの判断で、ｼｰﾄ内検索が出来ているﾛｼﾞｯｸを教えてください。知識不足で以下構文の理由が分からなくて。
If CopySheet Is Nothing The

[hatena19]

CopySheet関数ではシートの存在チェックをしていて、存在すればそのシートを戻り値として返す、
存在しなければ、テンプレートシートをコピーして名前変更してそれを返す、という処理をしています。
Set CopySheet = Worksheets(SheetName) で指定した名前のシートを戻り値(CopySheet)に代入します。
もし、指定した名前のシートが存在しなければエラーになりますが、上のコードでエラーを無視するようにしてますので、スルーして次のコードへ進みます。
If CopySheet Is Nothing Then
エラーでCopySheetに代入できていなかったら、中身がないので Nothing になっています。つまり、指定した名前のシートは存在しなかったと判断できます。

Answer 2

コメントにある通りActiveSheetは現在のシートがわかりにくくなるので使わない方がいいでしょうね。
また同一シート判定は判定フラグを用意してFor文を回してから、同一シートがあるかないかの処理をした方がいいと思います。

Sub シート作成andオートシェイプ作成()
    Dim i As Integer   '行カウンタ
    Dim k As Integer   '数量カウンタ
    Dim o As Long      'シートカウンタ
    Dim list As Worksheet 'リスト表
    Dim Tl As Worksheet 'カラオケシート
    Dim ash As Worksheet 'オートシェイプ追加シート
    Dim zukei As Shape '図形
    Dim shchk As Boolean '同一シート名チェックフラグ
    Set list = Worksheets("リスト表")
    Set Tl = Worksheets("カラオケ")

    lastR = list.Cells(Rows.Count, "B").End(xlUp).Row 'ｼｰﾄﾘｽﾄ B列のｾﾙ入力済最終行を定義
    lastC = list.Cells(2, Columns.Count).End(xlToLeft).Column 'ｼｰﾄﾘｽﾄ B列のｾﾙ入力済最終行を定義

    For i = 7 To lastR    '7行目から1行ずつ処理

      shchk = False
      For Each objSheet In ThisWorkbook.Worksheets  '同一ｼｰﾄ検索
        If objSheet.Name Like list.Cells(i, 1).Value Then
          Set ash = objSheet
          shchk = True
          Exit For
        End If
      Next
     
      If shchk = True Then
           X = list.Cells(i, 3).Value '横
           Y = list.Cells(i, 4).Value ' 縦
           Z = list.Cells(i, 5).Value ' 品名
           kazu = list.Cells(i, 6)
           iro = list.Cells(i, 7)
           For k = 1 To kazu

           Set zukei = ash.Shapes _
           .AddShape(msoShapeRectangle, 800, 30, X * 1.95, Y * 1.95)  '正面2ｼｰﾄへ図形作成

           With zukei
           .TextFrame.Characters.Text = X & "×" & Y & vbCrLf & Z '図形へテキスト入力
           .TextFrame.Characters.Font.Size = 15                  'テキスト文字フォント変更
           .TextFrame.Characters.Font.ColorIndex = 1             'テキスト文字色変更
           .TextFrame.HorizontalAlignment = xlHAlignCenter       'テキスト文字水平中央
           .TextFrame.VerticalAlignment = xlVAlignCenter         'テキスト文字垂直中央
           End With

           Next k

      Else
        Tl.Copy after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = list.Cells(i, 1).Value

      End If


    Next i

End Sub

Comments

[jabe]

コード作成いつもありがとうございます。
狙いどうりの動作になりました。
判定フラグをたてて、for文という考え方がなかったので勉強になりました。