Excel VBA 原本シートをコピーして名前を付ける方法

シートをコピーして、名前を付けて、任意の場所に差し込む

前回同様にシートをコピーしますが、コピーすると同時にシートに名前を付けます。
シート名が重複した際は、エラー対応で識別番号を入力するようにしています。
※本当は、(2)(3)と自動で付けたかったのですが、そこまでの能力はありませんでした(泣)

原本をコピーして、一番左端に挿入する

Sub 左端にコピー()

On Error GoTo myError 'エラーが起きた時点でmyErrorへ移動

  Dim NewSheetName As String
  
  NewSheetName = InputBox("新しいシート名を入力してください")
  
  Sheets("原本").Copy before:=Sheets(1)
  
  ActiveSheet.Select
  
  ActiveSheet.Name = NewSheetName
  
  ActiveWorkbook.Save
  
  Range("A1").Select
   
  Exit Sub

myError:  'エラー処理・シート名に認識番号を入れる
  Dim 識別番号 As Variant
  
  識別番号 = InputBox("既に同じシート名があります。" & Chr(13) & "識別番号を入力してください。")
  
  ActiveSheet.Name = NewSheetName & "(" & 識別番号 & ")"
  
  ActiveWorkbook.Save
  
  Range("A1").Select

End Sub

原本をコピーして、一番右端に挿入する

Sub 右端にコピー()

On Error GoTo myError 'エラーが起きた時点でmyErrorへ移動

  Dim NewSheetName As String
  
  NewSheetName = InputBox("新しいシート名を入力してください")
 
  Sheets("原本").Copy after:=Sheets(Sheets.Count)
 
  ActiveSheet.Select
  
  ActiveSheet.Name = NewSheetName
  
  ActiveWorkbook.Save
  
  Range("A1").Select
   
  Exit Sub

myError:  'エラー処理・シート名に認識番号を入れる
  Dim 識別番号 As Variant
  
  識別番号 = InputBox("既に同じシート名があります。" & Chr(13) & "識別番号を入力してください。")
  
  ActiveSheet.Name = NewSheetName & "(" & 識別番号 & ")"
  
  ActiveWorkbook.Save
  
  Range("A1").Select

End Sub

原本をコピーして、原本の左隣に挿入する

Sub 原本の左隣にコピー()

On Error GoTo myError 'エラーが起きた時点でmyErrorへ移動

  Dim NewSheetName As String
  
  NewSheetName = InputBox("新しいシート名を入力してください")
  
  Sheets("原本").Copy before:=Sheets("原本")

  ActiveSheet.Select
  
  ActiveSheet.Name = NewSheetName
  
  ActiveWorkbook.Save
  
  Range("A1").Select
   
  Exit Sub

myError:  'エラー処理・シート名に認識番号を入れる
  Dim 識別番号 As Variant
  
  識別番号 = InputBox("既に同じシート名があります。" & Chr(13) & "識別番号を入力してください。")
  
  ActiveSheet.Name = NewSheetName & "(" & 識別番号 & ")"
  
  ActiveWorkbook.Save
  
  Range("A1").Select

End Sub

原本をコピーして、原本の右隣に挿入する

Sub 原本の右隣にコピー()

On Error GoTo myError 'エラーが起きた時点でmyErrorへ移動

  Dim NewSheetName As String
  
  NewSheetName = InputBox("新しいシート名を入力してください")
  
  Sheets("原本").Copy after:=Sheets("原本")
 
  ActiveSheet.Select
  
  ActiveSheet.Name = NewSheetName
  
  ActiveWorkbook.Save
  
  Range("A1").Select
   
  Exit Sub

myError:  'エラー処理・シート名に認識番号を入れる
  Dim 識別番号 As Variant
  
  識別番号 = InputBox("既に同じシート名があります。" & Chr(13) & "識別番号を入力してください。")
  
  ActiveSheet.Name = NewSheetName & "(" & 識別番号 & ")"
  
  ActiveWorkbook.Save
  
  Range("A1").Select

End Sub

Sheets("原本").Copy before:=Sheets("原本")
Sheets("原本").Copy after:=Sheets("原本")
の「原本」の部分は目的のシート名に変更してください。

Sheets("原本").Copy before:=Sheets(1)
の「(1)」を「(2)」「(3)」等にすると左から２つ目、左から３つ目に差し込むことが出来ます。