vba excelシート作成

Option Explicit

Sub makeSheet()
    Dim wba As Workbook
    Dim wbb As Workbook
    Dim wsa As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim newwsmei As String
    Dim bl As Boolean
    Dim newwscnt As Integer
    Dim newwbmei As String
    Set wba = ThisWorkbook
    Set wsa = wba.Worksheets("Sheet1")
    newwscnt = 42

    If WorksheetFunction.CountA(wsa.Range(wsa.Cells(1, 1), wsa.Cells(newwscnt, 1))) <> newwscnt Then
    AppActivate Application.Caption
        MsgBox "新規シート名が入力されていないセルがあります。"
        Exit Sub
    End If

    bl = True

    For i = 1 To newwscnt
        If WorksheetFunction.CountIf(wsa.Range(wsa.Cells(i, 1), wsa.Cells(newwscnt, 1)), wsa.Cells(i, 1)) <> 1 Then
            bl = False
        End If
    Next i

    If bl = False Then
        AppActivate Application.Caption
        MsgBox "新規ファイル名が重複しています。"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Set wbb = Workbooks.Add
    For i = 1 To newwscnt
        newwsmei = wsa.Cells(i, 1).Value
        bl = True
        For j = 1 To wbb.Worksheets.Count
            If wbb.Worksheets(j).Name = newwsmei Then bl = False
        Next j

        If bl = True Then
        Worksheets.Add after:=wbb.Worksheets(wbb.Worksheets.Count)
        wbb.Worksheets(wbb.Worksheets.Count).Name = newwsmei
        End If
    Next i

    If wbb.Worksheets.Count > newwscnt Then
    Application.DisplayAlerts = False

    For k = wbb.Worksheets.Count - newwscnt To 1 Step -1
        wbb.Worksheets(k).Delete
        Next k
        Application.DisplayAlerts = True
    End If

    Application.ScreenUpdating = True
    newwbmei = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
    & "\" & Format(Now, "yymmdd_hhmmss") & ".xlsx"
    If Dir(newwbmei) <> "" Then
        AppActivate Application.Caption
        MsgBox newwbmei & vbCrLf & "は既に存在するブック名です。"
    Exit Sub
    End If

    wbb.SaveAs newwbmei
    wbb.Close
    Set wbb = Nothing
    Set wsa = Nothing
    Set wba = Nothing
End Sub