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

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

回答の条件
  • 1人2回まで
  • 登録:
  • 終了:2007/01/23 13:10:04
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

回答4件)

id:arhbwastrh No.1

回答回数447ベストアンサー獲得回数23

ポイント23pt

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

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

<||
id:ReoReo7

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

2007/01/16 15:25:11
id:Mook No.2

回答回数1314ベストアンサー獲得回数393

ポイント23pt

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


蛇足的な説明ですが、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...

id:ReoReo7

回答のとおりで望みの動作得られました。ありがとうございます。

しかしやはり20Sheetsくらい生成したところで当該のエラーとなり再起動がチョット面倒です。何とかならないでしょうか?

2007/01/19 11:37:35
id:degucho No.3

回答回数281ベストアンサー獲得回数75

ポイント22pt

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

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

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
id:ReoReo7

ありがとうございます。ご紹介いただいたページの最後に書いてある、「ワークシートのサイズに依存」ということですが現在メモリ700MB、ページサイズは1200行*30列くらいです。

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

2007/01/19 11:40:35
id:Mook No.4

回答回数1314ベストアンサー獲得回数393

ポイント22pt

とりあえず、マイクロソフトの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
id:ReoReo7

ありがとうございます。後ほど試してみたいと思います。200シートくらいあればかなり実用的です。

2007/01/19 11:41:47
  • id:taknt
    これは不具合なので エラーは 出ます。

    ただ、マシンの環境によっては(メモリが多いなど)、作成できるシート数の数が 変わってきます。

  • id:Mook
    何回かやるとエラーということでしたら、回答にも書きましたが、メモリ不足(?)等の原因が疑わしいですね。

    taknt さんも書かれていますが、作成できるシート数はマシン環境やコピーするシートのデータ量によっても変わるようです。
  • id:ReoReo7
    保存しなおしたり、再起動したり、いろいろ・・をしていると、
    コピーが再びできるようになっていたりしますが、
    これはやはりみなさんおっしゃるように
    メモリなどに依存しているということなんでしょうか。

    いろいろやってみます。
  • id:Mook
    こちらで試験したときには、シートの中身がほとんどなかったので、多くとも問題ありませんでしたが、実施の対象シートでやったときとは結果も変わるとは思います。

    ただ、EXCEL の不具合自体に対する対応はしましたので、これでどこまでいけるかというところでしょうか。

    状況が改善されると良いのですが。
  • id:ReoReo7
    遅くなりすみません。
    今試してみました。

    望みどおりで最高の動作を示しました。
    50シートのみ生成しましたが実用範囲内です。
    ありがとうございました。

    認識しないうちに終了してしまったので、
    みなさんには不足分のポイント後ほど送金しておきます。
    (方法がわからないので少し待ってください。)

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません