[[20141126100348]]　『ファイルを閉じる時にエラーが出る』（kuki）　ページの最後に飛ぶ

『ファイルを閉じる時にエラーが出る』（kuki）

 こんにちは。質問お願いします。

 フォルダ内にある特定のファイルを開いて、シートの画像をパワーポイントに
 コピペするというマクロを作成しているのですが、ファイルを開いて画像を
 コピペした後にファイルを保存しないで閉じるというコードのところでだんだん
 処理時間が長くなり、ファイル５個目くらいで「動作を停止しました」という
 表示がでて強制的に落ちてしまいます。
 開くファイルのサイズが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

もう1点。File_Collection も解放せずに再確保していますね。使い終わったら解放してみてください。
（???） 2014/11/26(水) 10:58

 ？？？さん

 アドバイスありがとうございます。
 上記の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

変わらなかったですか。難しいですね。
パワポを扱う pptapp も気になりましたが、これはループ外の宣言だし、抜けるときに自動開放されていると思います。

まずは、どの処理が原因で停止してしまうのか、難しそうな処理部分をコメント化して殺していって、探してください。
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

私自身、PCを新しいものに変えただけで、同じマクロがエラー中断するようになったことがあります。
処理速度が速いせいで、closeしてから次を開く間隔が短くなり、問題が出ているのかも知れません。
適度にDoEventsを入れてみるとか、Sleep APIを使ってみるのも手かも？

もうひとつ。自ブック以外なら閉じる、というロジック追加を行ったということは、
自ブックも同じフォルダにあるために、2つ目を開いている、ということはありませんか？
File_List のループの際、自ブック名と異なる場合だけ処理してみるとか。
（???） 2014/11/26(水) 15:04

コメント返信：

[ 一覧(最新更新順) ]

[[20141126100348]] 『ファイルを閉じる時にエラーが出る』（kuki） ページの最後に飛ぶ

[[20141126100348]]　『ファイルを閉じる時にエラーが出る』（kuki）　ページの最後に飛ぶ