エクセル ボタン VBA

質問

原本のシートがあり
AX1にボタン（保存）を作りました。

原本シートに記載していき
記載終わった時に作成したボタンを押すと
記載されたシートをコピーして新たな名前を付け自動的にシートを追加する
ことは可能でしょうか?
その際原本シートは元の記載されてない状態に戻したいのですが・・
（シートの名前は○○様○月○日みたいな感じにしたい）

回答No.1

kkkkkm · ベストアンサー

原本シートと同じものをひな形という名前で作成してください。
ボタンのマクロに以下のコードを割り当ててください。

Sub Example()
Dim MySheetName As String

MySheetName = InputBox("シート名を入力してください")
Sheets("原本シート").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = MySheetName
Sheets("ひな形").Range("A1:G20").Copy Sheets("原本シート").Range("A1")
End Sub

Sheets("ひな形").Range("A1:G20")
この範囲は実際にもとの原稿となる部分をA1基準で指定してください。

お礼

ありがとうございます
うまくできました

回答No.3

chie65536（@chie65535）

追記。

シート間で「セルの参照」があった場合、ボタンを押してプログラムを実行すると、セルの参照先が変更されるので注意して下さい。

例えば「原本シート」を参照しているセルが他のシートにあった場合、原本シートを「〇〇様〇月〇日」のシートにコピーすると、そのセルは「〇〇様〇月〇日」のシートを参照するようになります。

ですので「シート間のデータ参照」を行なう場合は「参照先が変更される」という事に注意して下さい。

前の回答で半角スペースが無くなって「桁揃え（インデント）」が消えてしまったので、プログラム部分を再投稿します（内容は同じです）

Private Sub 保存_Click()
　Dim SName As String
　Dim OldName As String
　Dim Ws As Worksheet
　Dim SExist As Boolean

　’元のシートの名前を記録しておく
　OldName = ActiveSheet.Name

　'既存のシート名が入力されたかどうかのフラグ
　SExist = True

　'存在しないシート名が入力されるまで入力を繰り返す
　While SExist
　　'新しいシート名の入力
　　SName = InputBox("シート名を入力してください")
　　'「キャンセル」が押されたら即座に終了
　　If SName = "" Then Exit Sub

　　'入力した名前と同じシートがあるかチェック
　　For Each Ws In Worksheets
　　　'既存のシート名と同名ならSExistをtrueにする
　　　SExist = Ws.Name = SName
　　　'既存のシート名を入力した場合の処理
　　　If SExist = True Then
　　　　'警告を表示
　　　　MsgBox "入力したシート名は既に存在します"
　　　　'それ以上調べる必要が無いのでForループを抜ける
　　　　Exit For
　　　End If
　　Next
　'新しい名前を入力した場合はWhileループを抜ける
　Wend
　'現在のシート（ボタンを押したシート）の名前を入力した名前にリネーム
　ActiveSheet.Name = SName
　'「原本シートの未記入原本」を、シートの先頭にコピーする
　Sheets("原本シートの未記入原本").Copy Before:=Sheets(1)
　'コピーした「原本シートの未記入原本(2)」を、元の名前（「原本シート」
　'という名前になっていた筈）にリネーム
　Sheets(1).Name = OldName
End Sub

お礼

ありがとうございます
何度試してもうまくいかずできませんでした
教えていただいたのに
私の力不足で申し訳ないです

回答No.2

chie65536（@chie65535）

＞原本シートに記載していき
＞記載終わった時に作成したボタンを押すと
＞記載されたシートをコピーして新たな名前を付け自動的にシートを追加することは可能でしょうか?

可能です。

その場合は

「原本シートの未記入原本」を「別の名前で準備」しておいて

１．「原本シート」を「入力した別の名前にリネーム」する

２．「原本シートの未記入原本」を「原本シート」にコピーする

と言う処理をします。

「原本シートの未記入原本」というシートと「原本シート」というシートを用意して、両方のシートに「コマンドボタン」を設置して「保存」という名前にして、両方のボタンの「クリック時」のイベントに以下のプログラムを記入して下さい。

Private Sub 保存_Click()
Dim SName As String
Dim OldName As String
Dim Ws As Worksheet
Dim SExist As Boolean

’元のシートの名前を記録しておく
OldName = ActiveSheet.Name

'既存のシート名が入力されたかどうかのフラグ
SExist = True

'存在しないシート名が入力されるまで入力を繰り返す
While SExist
'新しいシート名の入力
SName = InputBox("シート名を入力してください")
'「キャンセル」が押されたら即座に終了
If SName = "" Then Exit Sub

'入力した名前と同じシートがあるかチェック
For Each Ws In Worksheets
'既存のシート名と同名ならSExistをtrueにする
SExist = Ws.Name = SName
'既存のシート名を入力した場合の処理
If SExist = True Then
'警告を表示
MsgBox "入力したシート名は既に存在します"
'それ以上調べる必要が無いのでForループを抜ける
Exit For
End If
Next
'新しい名前を入力した場合はWhileループを抜ける
Wend
'現在のシート（ボタンを押したシート）の名前を入力した名前にリネーム
ActiveSheet.Name = SName
'「原本シートの未記入原本」を、シートの先頭にコピーする
Sheets("原本シートの未記入原本").Copy Before:=Sheets(1)
'コピーした「原本シートの未記入原本(2)」を、元の名前（「原本シート」
'という名前になっていた筈）にリネーム
Sheets(1).Name = OldName
End Sub