Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : その他)
初回マクロ実行時は正常動作。2回目以降は強制終了させられ、PC再起動後のリトライだと正常動作
投稿日時: 21/11/08 17:41:57
投稿者: Alice

Microsoft Excel for Microsoft 365 MSOを使用しています。
 
下記コード内で「★★★ここまでは毎回正常動作★★★」と記載している箇所までは正常動作するのですが、勝手にExcelが強制終了される状態です。
 
ネットでいろいろと調べ、DoEventsを入れてリトライしても同様だった為、試しにPC再起動後にリトライするとコードを正常動作します。
 
また、下記サイトよりkillを使用している点に問題があるのかと思い、fsoを使用してみましたが同様です。
https://teratail.com/questions/300583
 
すっかり手詰まりになってしまった為、書込みをした次第です。
 
どなたかアドバイスをいただけると幸いです。(その際、原因も記載して下さると有難いです。)
何卒宜しくお願い致します。
 

Public add_SCFlg1, add_SCFlg2 As Boolean
Sub SC_Register()

Dim target_row1, target_col1 As Long 'コピー元の該当範囲の行と列の変数
Dim target_row2, target_col2 As Long 'ペースト先の該当範囲の行と列の変数

Dim adopt_SC As String                  '「登録yyyymm(SC採用).xlsx」フルパス
Dim adopt_SC_name As String             '「登録yyyymm(SC採用).xlsx」ファイル名

Dim fso As New FileSystemObject         'ファイル削除時に使用

'コピー先ファイル(「SC為替レート登録」フォルダ内)を開く
Workbooks.Open SC
    SC_name = ActiveWorkbook.Name
    
    Worksheets("CMM003").Select
    
    '該当月の列を取得
    
     Cells.Find(what:="換算属性", lookat:=xlWhole).Select
     
     target_row1 = Selection.Row                  '日付を検索する行
     target_col1 = Selection.Offset(0, 1).Column  '日付を検索する列
     
        Do Until CStr(Cells(target_row1, target_col1).Value) = CStr(y & m2keta) '型を変更して(しかもlongとかではNG)比較しないと判別できないので「文字列型へのデータ変換」を行っている
        
            target_col1 = target_col1 + 1
        Loop
        
        target_row1 = Cells(target_row1, target_col1).Offset(1, 0).Row 'コピー開始行
            
'コピー元ファイル(「0000_**期決算資料」フォルダ内)をアクティブにする
Workbooks(RateWB_name).Activate

    Worksheets("CMM003").Select
    
    '該当月の列を取得
    Cells.Find(what:="換算属性", lookat:=xlWhole).Select
    
    target_row2 = Selection.Row                  '日付を検索する行
    target_col2 = Selection.Offset(0, 1).Column  '日付を検索する列
    
    Do Until CStr(Cells(target_row2, target_col2).Value) = CStr(y & m2keta)
    
        target_col2 = target_col2 + 1
    Loop
    
    target_row2 = Cells(target_row2, target_col2).Offset(1, 0).Row 'コピー開始行
    
    '該当月のデータをコピペ(RateWB_name側のデータをコピー)
   
        Range(Cells(target_row2, target_col2), Cells(Cells(Rows.Count, target_col2).End(xlUp).Row, target_col2)).Copy
    
            Workbooks(SC_name).Activate
                Worksheets("CMM003").Select
            
                Cells(target_row1, target_col1).PasteSpecial Paste:=xlPasteValues '値でペースト
    
    Workbooks(SC_name).Close savechanges:=True
    
        Application.DisplayAlerts = False
        
        Workbooks(RateWB_name).Close savechanges:=False
        
        '-----上記で作成したファイルをコピペ・リネームし「登録yyyymm(SC採用).xlsx」を作成------
        '(冒頭で取得した削除対象コードに該当する行を削除(「CMM003」シート))
        
        If NA_flg = "" Then

            'ファイルコピー・リネーム
            FileCopy SC, Left(SC, InStrRev(SC, ".xls") - 1) & "(SC採用)" & Mid(SC, InStrRev(SC, ".xls"))

                adopt_SC = Left(SC, InStrRev(SC, ".xls") - 1) & "(SC採用)" & Mid(SC, InStrRev(SC, ".xls")) '「登録yyyymm(SC採用).xlsx」のフルパスを変数に入れる
      
'★★★ここまでは毎回正常動作★★★

            'DoEvents      'stopとかいれて中断後、再開するとExcelが落ちずに済む為に入れている(Sleepも試したがExcelが落ちる)
            
            'ファイルを開き、該当箇所を検索
            Workbooks.Open adopt_SC
                adopt_SC_name = ActiveWorkbook.Name
                
                For k = 1 To UBound(d_code)
                    
                    On Error Resume Next
                    
                    If UBound(d_code) = 1 Then  '削除対象コードが一つ

                        Cells.Find(what:=d_code(1), lookat:=xlWhole).Select
                        
                                If Err.Number <> 0 Then   '配列に入れた削除対象コードが対象ファイルにない
                                
                                        'どのコードがないのか、配列をいれた対象シート上の該当コード記載のセルを黄色で塗りつぶし
                                        ThisWorkbook.Activate
                                            Worksheets("Sheet1").Select
                                            
                                                Cells.Find(what:=d_code(1), lookat:=xlWhole).Select
                                                Selection.Interior.Color = 65535                        '65535は黄色の色番号
                                                
                                                    Workbooks(adopt_SC_name).Activate '元のファイルをアクティブにする
                                        
                                   '作成した「登録yyyymm(SC採用)」ファイルを上書き保存せず閉じる
                                   Application.DisplayAlerts = False
                                   
                                   Workbooks(adopt_SC_name).Close savechanges:=False
                                   
                                   Application.DisplayAlerts = True
                                   
                                   '作成した「登録yyyymm(SC採用)」ファイルを削除
                                   
                                   fso.DeleteFile (adopt_SC)
                                   
                                   'Kill adopt_SC
                                   
                                        add_SCFlg1 = True '最後のメッセージ文言判別用フラグ付与
                                        Err.Clear  'ここで発生したエラークリア
                                   
                                   On Error GoTo 0
                                   
                                   GoTo TOBASU
                                
                                End If
                            
                    Else    '削除対象コードが複数

                        Cells.Find(what:=d_code(k, 1), lookat:=xlWhole).Select
                        
                            If Err.Number <> 0 Then      '配列に入れた削除対象コードが対象ファイルにない
                                    
                                    'どのコードがないのか、配列をいれた対象シート上の該当コード記載のセルを黄色で塗りつぶし
                                    ThisWorkbook.Activate
                                        Worksheets("Sheet1").Select
                                
                                        Cells.Find(what:=d_code(k, 1), lookat:=xlWhole).Select
                                        Selection.Interior.Color = 65535                        '65535は黄色の色番号
                                        
                                            Workbooks(adopt_SC_name).Activate '元のファイルをアクティブにする
                                
                                add_SCFlg2 = True '最後のメッセージ文言判別用、ファイル保存もしくは削除フラグ付与
                                Err.Clear  'ここで発生したエラークリア
                                
                                GoTo TSUGI
                            
                            End If
                            
                    End If
                    
                    'DoEvents      'stopとかいれて中断後、再開するとExcelが落ちずに済む為に入れている(Sleepも試したがExcelが落ちる)
                    
                    On Error GoTo 0

                        r = Selection.Row '最初に見つかったセルの行番号
                        c = Selection.Column '最初に見つかったセルの列番号

                        '該当行選択

                        i = 1
                        Do While Cells(r, c) = Cells(r, c).Offset(1, 0)

                            Selection.Resize(i + 1, 1).Select

                                i = i + 1
                                r = r + 1

                        Loop

                        '該当行削除
                        Selection.EntireRow.Delete
                        
                        add_SCFlg3 = True '最後のメッセージ文言判別用、ファイル保存もしくは削除フラグ付与
TSUGI:

                Next k
                
                        If UBound(d_code) > 1 And add_SCglg2 = True And add_SCglg3 = False Then
                        
                            '作成した「登録yyyymm(SC採用)」ファイルを上書き保存せず閉じる
                        
                            Application.DisplayAlerts = False
                            
                                Workbooks(adopt_SC_name).Close savechanges:=False
                                
                            Application.DisplayAlerts = True
                            
                                '作成した「登録yyyymm(SC採用)」ファイルを削除
                                
                                fso.DeleteFile (adopt_SC)
                                'Kill adopt_SC
                                
                                GoTo TOBASU
                                    
                        End If
                        
        End If

        Workbooks(adopt_SC_name).Close savechanges:=True
        
        'DoEvents
        
        Application.DisplayAlerts = True
         '--------------------------------
TOBASU:
 
End Sub

回答
投稿日時: 21/11/08 18:47:55
投稿者: sk

引用:
Workbooks.Open SC
SC_name = ActiveWorkbook.Name

引用:
Workbooks(SC_name).Close savechanges:=True

引用:
'ファイルコピー・リネーム
FileCopy SC, Left(SC, InStrRev(SC, ".xls") - 1) & "(SC採用)" & Mid(SC, InStrRev(SC, ".xls"))
adopt_SC = Left(SC, InStrRev(SC, ".xls") - 1) & "(SC採用)" & Mid(SC, InStrRev(SC, ".xls")) '「登録yyyymm(SC採用).xlsx」のフルパスを変数に入れる

引用:
'ファイルを開き、該当箇所を検索
Workbooks.Open adopt_SC
adopt_SC_name = ActiveWorkbook.Name

「編集したブック( SC )を上書き保存してから一旦閉じ、
そのブックを複製して、複製されたブック( adopt_SC )を開く」
という手順に、そもそも無駄なプロセスが多いような気が
しなくもないですが。
 
上書き保存後に編集したブックを別名で保存したいなら、
基本的には SaveAs メソッドを使えば済むのではないでしょうか。

回答
投稿日時: 21/11/08 19:44:24
投稿者: simple

DoEventsを一回といわず5,6回続けて実行するようなコードにして、
ファイルコピーする余裕をOS側に与えるとよいかもしれません。(試しておりませんが)
 
ただ、それはあくまで対症療法であり、
skさん提示の根本的解決方法をとったほうがよいと思います。

回答
投稿日時: 21/11/09 11:36:23
投稿者: Suzu

エラーが出るなら、
 画面制御を外して確認してください。
  ScreenUpdating = False
  DisplayAlerts = True
 
エラートラップを解除し、エラーが無いか確認してください。
今回のエラートラップ では、
  If Err.Number <> 0 Then '配列に入れた削除対象コードが対象ファイルにない
としていますが、エラーが発生するのは、見つからないからとは限りません。
 
今回は、直前の Find で、対象セルを SELECT しようとしていて
対象セルが無いので、セレクトしようとして
実行時エラー :91 が発生するのでは?
 
 
本来であれば、
 
Dim rng As Range
Set rng = Cells.Find(What:=〜)
If rng Is Nothing Then
  'ない場合
   MsgBox "対象なし"
Else
  'ある場合
   MsgBox "対象あり"
End If
 
の様な分岐を行い検索対象の あり/なし を判定すべきです。
 
あるいは、
MsgBox WorksheetFunction.CountIfs(Cells, "A")
の様な、CountIfs を使用しても良いでしょう。
 
あくまでエラートラップで行うなら、Err.Number<>0 ではなく、
Err.Number = 91 で判定すべきです。
 
 
エラーが発生させると、余計な負荷がかかります。
 
それをユーザーに知らせるメッセージを非表示にしているので余計な負荷が蓄積します。
場合によっては 今回の様な 「落ちる」事もありえます。
 
いかにエラーを発生させないようにするか を考えましょう。
 
 
 

引用:
Workbooks.Open adopt_SC
 adopt_SC_name = ActiveWorkbook.Name
  (中略)
        Workbooks(adopt_SC_name).Activate '元のファイルをアクティブにする
        '作成した「登録yyyymm(SC採用)」ファイルを上書き保存せず閉じる
        Application.DisplayAlerts = False
        Workbooks(adopt_SC_name).Close savechanges:=False
        Application.DisplayAlerts = True
       '作成した「登録yyyymm(SC採用)」ファイルを削除
       fso.DeleteFile (adopt_SC)

 
最後のの命令にて削除しようとする ファイルですが 他のかたのご指摘にもある
別名でコピーしたファイルですよね?
 
このファイル、削除するならなぜ別名でコピーが必要なのでしょう?
 
しかも直前で、閉じて削除。
ファイルを 読み取り専用で開いているならまだしも、そうではないです。
 
内部的に、閉じる処理が終わらない状態で ファイル削除命令が発せられている可能性もあります。
これも負荷の原因となりえると思います。
 
 
他の回答者の方と同じになりますが、
 
 1. ファイルを閉じ別名コピー
 2. 別名ファイルを開く
 3. 保存をせずに閉じる
 4. 別名ファイルを削除
 
この流れが必要なのか。見直しをしてみてください。

投稿日時: 21/11/09 12:33:18
投稿者: Alice

SK様、simple様、Suzu様
 
皆様、アドバイスを下さり本当にありがとうございます。
 
皆様からの共通のアドバイスである下記ムダな動作をなくしたところ、Excelが強制終了しなくなりました!!
 
1. ファイルを閉じ別名コピー
2. 別名ファイルを開く
3. 保存をせずに閉じる
4. 別名ファイルを削除
 
 ↓↓
 
別途配列に入れた削除対象データがある場合、別名ファイルで保存する流れに変更
 
---------
 
PCは、こちらの言うことを全て聞きいれるのかと思いましたが、フローの作り方によってはそうでもないことが分かりました。。
(ご指摘のとおり、もっさりとしたフローとは思っていたのですが、機械任せにするからやってくれるだろうと思っていました。)
 
大変勉強になりました。
早速アドバイスを寄せて下さり、心から感謝です。ありがとうございました。