次の仕様のマクロを作ってください。
(1)Sub Creat_Sheets()
1.今アクティブなシートについて今のシートの後ろにコピーを作成する
2.そのシートの名称("g"&"数字")を、("g"&"今あるシートの数字+1")とする。
たとえば、今あるシートの名称が
g300
の場合
g301
という名称のシートをコピーする。
3.A1セルの名称を、そのシートの名称と同じにする。
今の場合A1セルを
g301
という名称にする。
そして新しくできたシートのA1セルをアクティブにしたまま終了。
(2)Sub Creat_10Sheets()
Sub Creat_Sheets()
を10回実行する。
(3)Sub Creat_50Sheets()
Sub Creat_10Sheets()
を5回実行する。
※現在、マクロの記録機能で、あるシートをコピーするだけのマクロを記録しました。何枚かコピーすると次のようなエラーメッセージが出ます。
"
実行時エラー '1004':
Worksheet クラスの Copy メソッドが失敗しました。
"
ですのでなるべくこのエラーを回避または起こったときの対処法も一緒に教えてください。
お力添えよろしくお願いします。
エラー処理を入れていないので、もしエラーが出るようであれば教えてください。
Sub Creat_Sheets() Dim name As String Dim leftname As String name = ActiveSheet.name ActiveSheet.Copy after:=ActiveSheet leftname = Left(name, 1) name = Mid(name, 2) name = name + 1 leftname = leftname + name Range("A1").Value = leftname ActiveSheet.name = Range("a1").Value Range("A1").Activate End Sub Sub Creat_10Sheets() i = 1 For i = 1 To 10 Creat_Sheets Next End Sub Sub Creat_50Sheets() i = 1 For i = 1 To 5 Creat_10Sheets Next End Sub <||
今回はだいぶ余計な関数を作成しましたが、この方が無駄がない気がしましたので、ご参考になればと思います。
蛇足的な説明ですが、Private と Public を明示することで、EXCEL から マクロを実行を選択した際に表示されるマクロ名を制限できますので、今回のような場合に有効です。
Option Explicit '------------------------------------------------------ Public Sub Creat_Sheets() '------------------------------------------------------ CreateNewSheet End Sub '------------------------------------------------------ Public Sub Create_10Sheets() '------------------------------------------------------ CreatSheets 10 End Sub '------------------------------------------------------ Public Sub Create_50Sheets() '------------------------------------------------------ CreatSheets 50 End Sub '------------------------------------------------------ Private Sub CreatSheets(num As Integer) '------------------------------------------------------ ' Numシート作成:失敗したら途中で終了 '------------------------------------------------------ Dim i As Integer For i = 1 To num If CreateNewSheet() = False Then Exit Sub End If Next End Sub '------------------------------------------------------ Private Function CreateNewSheet() As Boolean '------------------------------------------------------ ' 1シート作成機能を関数として実装 '------------------------------------------------------ Dim sheetName As String sheetName = ActiveSheet.Name Dim newSheetName As String newSheetName = "g" & CInt(Mid(sheetName, 2)) + 1 '--- シート名が重ならないことを確認 If sheetNameCheck(newSheetName) = False Then MsgBox newSheetName & "はすでに存在しています。" CreateNewSheet = False Exit Function End If '--- シートをコピー ActiveSheet.Copy after:=ActiveSheet '--- シート名を変更 ActiveSheet.Name = newSheetName '--- A1 にシート名を設定 ActiveSheet.Range("A1").Value = newSheetName CreateNewSheet = True End Function '------------------------------------------------------ Private Function sheetNameCheck(sheetName As String) As Boolean '------------------------------------------------------ ' シートの有無を確認 '------------------------------------------------------ Dim ws As Worksheet ' --- オブジェクトに設定 On Error Resume Next Set ws = Worksheets(sheetName) On Error GoTo 0 ' --- シートが存在しなければ Nothing If ws Is Nothing Then sheetNameCheck = True Else sheetNameCheck = False End If End Function
エラーに関してはそのときのシートの状態と、マクロが判らないので明確な回答は難しいですが、シートを削除してから実行したりしていないでしょうか。
こればかりは、ケースバイケースで一意の解決法がないので、都度原因を探るしかないかと思います。
追加情報ですが、
ネットで検索したところ、シートを多数コピーすると当該エラーになることがある、との情報もありましたので多量のシートコピーは避けたほうが無難かもしれません。http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=22372;id=ex...
回答のとおりで望みの動作得られました。ありがとうございます。
しかしやはり20Sheetsくらい生成したところで当該のエラーとなり再起動がチョット面倒です。何とかならないでしょうか?
名前が重複したときの処理が不明ですが
以下で可能かと思います。
takntさんのコメントにもあるように
公式の不具合なので書式が決まっている場合は
テンプレートで逃げるしかないようです
http://support.microsoft.com/kb/210684/ja
それでも結局メモリ依存ですが
Option Explicit Sub Creat_Sheets() Dim orgSheet As Worksheet Dim newSheet As Worksheet Dim orgName As String Dim orgNumber As Long On Error GoTo er Set orgSheet = ActiveSheet orgName = orgSheet.Name If Not (orgName Like "g*") Then Exit Sub End If orgNumber = Val(Right(orgName, Len(orgName) - 1)) If (orgNumber = 0) Then Exit Sub End If orgSheet.Copy After:=orgSheet Set newSheet = Worksheets(orgSheet.Index + 1) With newSheet .Name = "g" + CStr(orgNumber + 1) .Range("A1").Value = .Name End With ex: On Error Resume Next Set orgSheet = Nothing Set newSheet = Nothing Exit Sub er: Call MsgBox(CStr(Err.Number) + ":" + Err.Description, vbExclamation) Resume ex End Sub Sub Creat_10Sheets() Dim i As Long For i = 1 To 10 Creat_Sheets Next End Sub Sub Creat_50Sheets() Dim i As Long For i = 1 To 50 Creat_Sheets Next End Sub
ありがとうございます。ご紹介いただいたページの最後に書いてある、「ワークシートのサイズに依存」ということですが現在メモリ700MB、ページサイズは1200行*30列くらいです。
ご紹介頂いたプログラムはテンプレート適用のものでしょうか?自分で確認すべきところ、多忙のため質問ばかりして申し訳ありません。
とりあえず、マイクロソフトのTIPS にあるように、テンプレートファイルを読み込むように変更してみました。
処理速度は遅くなりますが、エラーはなくなるかと思います(と期待)。
とりあえず 200 シートまでは落ちませんでした。
赤い部分が変更点です。
Option Explicit '--- 作業用テンプレートファイル Const tmpFilePath = "C:\temp\tmp.xlt" '------------------------------------------------------ Public Sub Creat_Sheets() '------------------------------------------------------ CreatSheets 1 End Sub '------------------------------------------------------ Public Sub Create_10Sheets() '------------------------------------------------------ CreatSheets 10 End Sub '------------------------------------------------------ Public Sub Create_50Sheets() '------------------------------------------------------ CreatSheets 50 End Sub '------------------------------------------------------ Private Sub CreatSheets(num As Integer) '------------------------------------------------------ ' Numシート作成:失敗したら途中で終了 '------------------------------------------------------ '--- テンプレートの作成 saveTemplate Dim i As Integer For i = 1 To num If CreateNewSheet() = False Then Exit For End If Next '--- テンプレートの削除 CreateObject("Scripting.FileSystemObject").DeleteFile (tmpFilePath) End Sub '------------------------------------------------------ Private Sub saveTemplate() '------------------------------------------------------ ' アクティブページをテンプレートとして保存 '------------------------------------------------------ ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=tmpFilePath, FileFormat:=xlTemplate ActiveWorkbook.Close End Sub '------------------------------------------------------ Private Function CreateNewSheet() As Boolean '------------------------------------------------------ ' 1シート作成機能を関数として実装 '------------------------------------------------------ Dim sheetName As String sheetName = ActiveSheet.Name Dim newSheetName As String newSheetName = "g" & CInt(Mid(sheetName, 2)) + 1 '--- シート名が重ならないことを確認 If sheetNameCheck(newSheetName) = False Then MsgBox newSheetName & "はすでに存在しています。" CreateNewSheet = False Exit Function End If '--- ***テンプレートシートを読み込むように変更 Sheets.Add Type:=tmpFilePath, After:=ActiveSheet '--- シート名を変更 ActiveSheet.Name = newSheetName '--- A1 にシート名を設定 ActiveSheet.Range("A1").Value = newSheetName CreateNewSheet = True End Function '------------------------------------------------------ Private Function sheetNameCheck(sheetName As String) As Boolean '------------------------------------------------------ ' シートの有無を確認 '------------------------------------------------------ Dim ws As Worksheet ' --- オブジェクトに設定 On Error Resume Next Set ws = Worksheets(sheetName) On Error GoTo 0 ' --- シートが存在しなければ Nothing If ws Is Nothing Then sheetNameCheck = True Else sheetNameCheck = False End If End Function
ありがとうございます。後ほど試してみたいと思います。200シートくらいあればかなり実用的です。
わかりました。ありがとうございます。