人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

合計で200ポイント差し上げます。エクセルのマクロについて質問です。
次の仕様のマクロを作ってください。


(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 メソッドが失敗しました。
"
ですのでなるべくこのエラーを回避または起こったときの対処法も一緒に教えてください。

お力添えよろしくお願いします。

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:A1 sub アクティブ エクセル エラー
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● arhbwastrh
●23ポイント

エラー処理を入れていないので、もしエラーが出るようであれば教えてください。

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

<||
◎質問者からの返答

わかりました。ありがとうございます。


2 ● Mook
●23ポイント

今回はだいぶ余計な関数を作成しましたが、この方が無駄がない気がしましたので、ご参考になればと思います。


蛇足的な説明ですが、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くらい生成したところで当該のエラーとなり再起動がチョット面倒です。何とかならないでしょうか?


3 ● degucho
●22ポイント

名前が重複したときの処理が不明ですが

以下で可能かと思います。

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列くらいです。

ご紹介頂いたプログラムはテンプレート適用のものでしょうか?自分で確認すべきところ、多忙のため質問ばかりして申し訳ありません。


4 ● Mook
●22ポイント

とりあえず、マイクロソフトの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シートくらいあればかなり実用的です。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ