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