【VBA】一瞬でシートのコピー、名前変更が出来る方法

今回は、簡単にシートを複製するマクロを作ります。

最初に、ソースコードを記載します。

vb.シートのコピー

Sub シートをコピーする()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("見積書")

Dim wsName As String
wsName = ws.Cells(3, 1).Value

' 同名のワークシートがないことをチェック
If nameCheckFlag(wsName) = True Then

    MsgBox "同名のシートが存在するため、シートを作成できません。"

Else
    ' 「見積書」シートをコピーして一番右に追加する。
    ws.Copy After:=Sheets(Sheets.Count)

    ' 追加したシートがActiveになっているので、ActiveSheetを通じて名前を設定する。
    ActiveSheet.name = wsName

End If

' 見積書シートをアクティブにする
ws.Activate

End Sub

' 同名のワークシートがないかチェックする関数
Function nameCheckFlag(wsName As String) As Boolean
    Dim ws As Worksheet

    For Each ws In Worksheets
        If wsName = ws.name Then
            nameCheckFlag = True
            Exit For
        Else
            nameCheckFlag = False
        End If
    Next ws

End Function

今回は、以下のサンプルシートを使用します。

マクロを動かすと、見積書シートがコピーされ、末尾に会社名でシートがコピーされます。

それでは、詳細について書いていきます。

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("見積書")

こちらで、コピー対象のwsを変数に格納しています。

Dim wsName As String
wsName = ws.Cells(3, 1).Value

ここでは、コピーしたシートの名前を取得してます。
取得名は会社名としたいので、列は3、行は1を指定しています。

If nameCheckFlag(wsName) = True Then

こちらで、同名のシートがないか確認しています。
同名のシートが存在していた場合は、MsgBoxにてエラーメッセージを表示します。

Function nameCheckFlag(wsName As String) As Boolean
    Dim ws As Worksheet

    For Each ws In Worksheets
        If wsName = ws.name Then
            nameCheckFlag = True
            Exit For
        Else
            nameCheckFlag = False
        End If
    Next ws

End Function

上記が同名のシートが存在するかチェックする関数です。

For Each ws In Worksheets
        If wsName = ws.name Then
            nameCheckFlag = True
            Exit For
        Else
            nameCheckFlag = False
        End If
    Next ws

For Eachを使用し、全てのワークシートを1ずつチェックし、
同名なものが1つでもあった場合はTrueを返し、Exit Forでループ終了しています。

ws.Copy After:=Sheets(Sheets.Count)

上記では、コピーしたシートを末尾に設置します。

ActiveSheet.name = wsName

コピーすると、コピーされたシートがアクティブになるため、
会社名を格納したwsNameでシート名を変更します。

ws.Activate

コピーとシート名の変更が完了したら、アクティブシートを見積書に戻してます。

以上が、シートを複製するマクロになります。