[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ファイルを閉じる時にエラーが出る』(kuki)
こんにちは。質問お願いします。
フォルダ内にある特定のファイルを開いて、シートの画像をパワーポイントに コピペするというマクロを作成しているのですが、ファイルを開いて画像を コピペした後にファイルを保存しないで閉じるというコードのところでだんだん 処理時間が長くなり、ファイル5個目くらいで「動作を停止しました」という 表示がでて強制的に落ちてしまいます。 開くファイルのサイズが2M〜4Mほどあったのでそれが原因かなと思い、不要な シートはすべて削除して400KBくらいにして試してみましたが、ダメでした。 原因がわかる方がいらっしゃいましたらご教授願います。
Sub ListUp_FolderList(FolderSpec)
'FolderSpecのサブフォルダをすべて検索して配列変数Folder1に格納 Set Folder_Collection = CreateObject("Scripting.FileSystemObject").GetFolder(FolderSpec).SubFolders
cnt = 1 For Each Folder_List In Folder_Collection ReDim Preserve Folder1(cnt - 1) If Right(Folder_List.Name, 3) = "MAP" Then Folder1(cnt - 1) = Folder_List.Name Range("A" & Format(cnt)) = Folder_List.Name cnt = cnt + 1 End If Next Folder_List Set Folder_Collection = Nothing
'パワーポイントを立ち上げる。 MSG = MsgBox("新規でパワーポイントファイルを立ち上げますか?", vbYesNo) Set pptapp = CreateObject("PowerPoint.Application")
If MSG = vbYes Then pptapp.Visible = True '新規にプレゼンテーションを作成する Set newtpp = pptapp.Presentations.Add Else filepath = Application.GetOpenFilename("PowerPoint プレゼンテーション,*.pptx?;*.ppt") 'ファイル選択されている場合は、ファイルを開く。 If filepath <> "False" Then Set newtpp = pptapp.Presentations.Open(Filename:=filepath) Else MsgBox ("キャンセルされました。マクロ終了します") Exit Sub End If End If With newtpp.PageSetup ppH = .SlideHeight * 0.8 ppW = .SlideWidth * 0.8 End With Dim aaa Dim gsu cnt = 1 For Each file In Folder1 Set File_Collection = CreateObject("Scripting.FileSystemObject").GetFolder(FolderSpec & "\" & file & "\").Files
For Each File_List In File_Collection ReDim Preserve Folder2(cnt - 1) aaa = Right(File_List.Name, 6) If Right(File_List.Name, 6) = "a.xlsx" Then Folder2(cnt - 1) = File_List.Name Range("B" & Format(cnt)) = File_List.Name Workbooks.Open File_List.Path KWB = ActiveWorkbook.Name MPath = Mid$(File_List.Name, 1, InStr(File_List.Name, "_") - 1)
With Workbooks(KWB) With .Worksheets("ppt貼付用") .Select gsu = .Shapes.Count If gsu = 1 Then .Shapes.SelectAll Selection.Copy Else .Shapes.SelectAll Selection.Group Selection.Copy End If End With End With
Set ppSld = newtpp.Slides.Add(Index:=cnt, Layout:=12)
Set txt = ppSld.Shapes.AddTextbox( _ Orientation:=msoTextOrientationHorizontal, _ Left:=0, _ Top:=0, _ Width:=350, _ Height:=10)
With txt .Name = "AddedTextBox" .TextFrame.TextRange = MPath .TextEffect.FontSize = 40 End With
ppSld.Shapes.Paste
With ppSld.Shapes(2) .LockAspectRatio = msoTrue .Top = 50 .Left = 15 .Height = ppH .Width = ppW End With ↓↓ここで動作が停止する↓↓ Workbooks(KWB).Close SaveChanges:=false
cnt = cnt + 1 End If Next File_List Next file End Sub
< 使用 Excel:Excel2010、使用 OS:Windows7 >
長いのでちゃんと追ってはいませんが、気になるのは、Closeするブックを明示していない点。
オブジェクト指定せずにOpenし、Openするとアクティブになる事を利用してブック名を得ており、
ロジック的にはうまく動きそうですが、他のプロセスが介在できる隙があるのが気になります。
以下のような変更を試してみてください。
With Workbooks.Open(File_List.Path) … .Close SaveChanges:=False End With (???) 2014/11/26(水) 10:50
???さん
アドバイスありがとうございます。 上記の2点変更して試してみましたが、やはりcloseのところで 徐々に処理の時間が長くなっていき、5ループ目くらいで動作が停止してしまいます。
動作が停止した時にでる詳細は以下になります。
問題イベント名: APPCRASH アプリケーション名: EXCEL.EXE アプリケーションのバージョン: 14.0.7109.5000 アプリケーションのタイムスタンプ: 522a4035 障害モジュールの名前: StackHash_2e55 障害モジュールのバージョン: 6.1.7601.18247 障害モジュールのタイムスタンプ: 52eaf24 例外コード: c0000374 例外オフセット: 00000000000c4102 OSバージョン: 6.1.7601.2.1.0.256.48 ロケールID: 1041
(kuki) 2014/11/26(水) 12:13
まずは、どの処理が原因で停止してしまうのか、難しそうな処理部分をコメント化して殺していって、探してください。
AddTextbox関係をやめてみる、とか。
(???) 2014/11/26(水) 13:26
???さん
コメントありがとうございます。 今ひとつづつ確認中です。
それとは別に試しにループの中でファイルを閉じずにループを抜けた後に すべてのファイルを閉じるようにしたところエラーが出ませんでした。 ループ内で閉じるとダメとかあるんですかね? ただこれだとファイルがめちゃくちゃ溜まってしまうのでできれば 一つづつ閉じていくやり方ができればと思っています。
ループの後に追加したコードは以下になります。 Dim bk As Workbook
For Each bk In Workbooks If Not bk Is ThisWorkbook Then bk.Close SaveChanges:=False End If Next bk
(kuki) 2014/11/26(水) 14:30
もうひとつ。自ブック以外なら閉じる、というロジック追加を行ったということは、
自ブックも同じフォルダにあるために、2つ目を開いている、ということはありませんか?
File_List のループの際、自ブック名と異なる場合だけ処理してみるとか。
(???) 2014/11/26(水) 15:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.