VBA 既存のワークシートを名前を変えてコピーする

2018.11.22
スポンサーリンク

前回同様,
Excelの VBAで 既存のワークシートを名前を変えてコピーするサブ関数として作ります。

VBA sub関数「既存のワークシートを名前を変えてコピー」の仕様

Excel VBAで現在あるワークシートの１シートを特定して
ワークシートの最後へコピーを行い、
指定したかワークシート名に変更後、
その追加したワークシート開く（アクティブにする）プログラム
もし既に、同一名のワークシートが存在している場合は、
コピーは行わずそのワークシートを開く（アクティブにする）仕様で作ります。

VBA sub関数「既存のワークシートを名前を変えてコピー」のソース

ソースの前半部分で、
前回の同様に同一名のワークシートが存在しているかチェック、
存在の有無フラグ SheetExistをセット、
存在していればそのワークシートをSelectメソッドでアクティブにします。

後半部分は、
同一名のワークシートが存在してなければ、
ワークシートの最後に既存のワークシート「Template1」をコピー
指定されたワークシート名に変更

ワークシートをコピーした時点で、そのシートはアクティブになります。

ソースです。

'
' 既存のワークシートを名前を変えてコピー
'   SheetName = コピーしたワークシート名
'
Sub CopySheetLast(SheetName As String)
    Dim I As Integer
    Dim S As String
    Dim SheetExist As Boolean
    
    SheetExist = False
    
    For I = 1 To Worksheets.Count
        S = Worksheets(I).Name
        If S = SheetName Then
            ' 同一名のワークシート在り
            SheetExist = True
            Worksheets(I).Select
            Exit For
        End If
    Next
    
    If SheetExist = False Then
        ' 新しくワークシートを追加
        Worksheets("Template1").Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = SheetName
    End If
    

End Sub

VBA sub関数「 既存のワークシートを名前を変えてコピー」の実行

作った「 既存のワークシートを名前を変えてコピー」関数を実行させる簡単なsub関数を用意しました。

Sub test()
   ' 「最後にシートを追加」というワークシートを最後に追加
    CopySheetLast ("Copyしたテンプレート")
End Sub

実行前

実行後

既存していたワークシート「Template1」が「Copyしたテンプレート」の名前のワークシートで最後にコピーされました。

次は、
既に同一名のワークシートがある場合で検証を

実行前です

既に同一名のワークシートがある場合での実行後

新たなワークシートは作られず
指定した名前のワークシートが開かれました（アクティブに）

この「既存のワークシートを名前を変えてコピー」関数も改修

前回の記事同様、

VBA 新しいワークシートを追加する
Excel VBA 新しいワークシートを追加するサブ関数として作ります。 VBA sub関数「VBA 新しいワークシートを追加」の仕様 Excel VBAで現在あるワークシートの最後に、新しいワークシートを名前を指定して追加後、その追加した...
info-biz.club
2018.11.21

Excelのワークシート名の特性上、

ワークシートの重複判定の部分と、

戻り値で有効なワークシート名を取得できるようにする必要が有るため

改修しました。

そのソースは、

' 既存のワークシートを名前を変えてコピー
'   SheetName = コピーしたワークシート名
'
' 【戻り値】有効なワークシート名
'
Function CopySheetLast(SheetName As String) As String
    Dim I As Integer
    Dim S As String
    Dim CopyS As String
    Dim SheetExist As Boolean
    
    SheetExist = False
    CopyS = StrConv(LCase(SheetName), vbNarrow)
    
    For I = 1 To Worksheets.Count
        S = Worksheets(I).Name
        If StrConv(LCase(S), vbNarrow) = CopyS Then
            ' 同一名のワークシート在り
            SheetExist = True
            Worksheets(I).Select
            CopySheetLast = S
            Exit For
        End If
    Next
    
    If SheetExist = False Then
        ' 新しくワークシートを追加
        Worksheets("Template1").Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = SheetName
        CopySheetLast = SheetName
    End If

End Function

になります。