ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています

古いプログラムで10年以上使っています。
一番下のフォルダには、以前古いエクセルファイル Excel 97-2003 ワークシート (.xls) が入っていました。（簡単なマクロも入っています）
そのファイル群の合計データの一部を項目別に入荷集計表に反映するプログラムです。

マイクロソフトで古いエクセルファイルのサポートが終わっていましたので、ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています。

対応方法をご教授いただけると大変助かります。
FileSearch2007が使えなくなったことも原因かなと思うのですが、
どうしてもわからなく困っています。

新しいファイル検索のプログラムがあるようなのですが、
初心者のため、理解が難しく非常に困難な状況に置かれています。

最新のエクセルで動作するようプログラムを教えていただけるでしょうか。

現在のプログラムは下記にあります。
"C:\Users\ユーザーアカウント名\Desktop\在庫表\受払.xlsm"
このプログラムを使って、
C:\Users\ユーザーアカウント名\Desktop\在庫表\在庫表詳細\顧客にある*.xlsm"ファイルを検索して別の集計表に反映するプログラムです。

どうか、よろしくお願いいたします。

－－－－－－－以下プログラム－－－－－－－
Dim FAR(1999), AR(1999, 9), ゼロ表示, 件数, 最終行
Dim wkDate As Date

Sub P11_フォルダ内容書出し()
記入済データを消去_11
進度表示_11
パス名Book名を配列ARに格納_11
個別Bookの内容を配列に格納_11
配列の内容をシートに記入_11
並び替え_11
End Sub

'*---------------------------------------------------------------------------------*
Function 記入済データを消去_11()
Worksheets("入荷集計表").Activate
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Msg = "シート「入荷集計表」を最新の状態に更新します。実行しますか？"
msg_rt = MsgBox(Msg, vbYesNo)
If msg_rt <> vbYes Then End
If Range("B4") <> "" Then
Rows("4:" & 1999).Delete Shift:=xlUp
End If
If IsDate(Range("G2")) Then
wkDate = CDate(Range("G2"))
Else
wkDate = CDate("2060/12/31")
End If
Debug.Print Format(wkDate, "yyyy/mm/dd")
End Function

'*---------------------------------------------------------------------------------*
Function パス名Book名を配列ARに格納_11()
k = -1
target_path = ThisWorkbook.Path
target_extention = UCase("xlsm")
Set found_file = FileSearch2007(target_path, target_extention)
件数 = found_file.Count
If 件数 = 0 Then
MsgBox "*.xlsmファイルがないため処理を終了します。"
End
End If
For i = 1 To 件数
If Right(found_file(i), 10) <> "フォーマット.xlsm" And _
Right(found_file(i), 7) <> "在庫表.xlsm" Then
k = k + 1
FAR(k) = found_file(i)
End If
Next
End Function

'*---------------------------------------------------------------------------------*
Function 個別Bookの内容を配列に格納_11() '合計の行をFIND関数で検索する　　Do～Loopは時間がかかるため
Dim Idx1 As Integer
k = -1
For i = 0 To 1999
If FAR(i) = "" Then Exit For
Workbooks.Open Filename:=FAR(i), UpdateLinks:=0 '外部リンクを表示しない
For Idx1 = 7 To 1000
If Range("C" & Idx1) = "" Then
Exit For
End If
k = k + 1
AR(k, 0) = FAR(i)
AR(k, 1) = Range("E1")
AR(k, 2) = Range("M2")
AR(k, 3) = Range("C2")
AR(k, 4) = Range("H2")
AR(k, 5) = Range("C3")
AR(k, 6) = Range("B" & Idx1)
AR(k, 7) = "'" & Range("C" & Idx1)
AR(k, 8) = Format(Range("Z" & Idx1), "0.0")
AR(k, 9) = "'" & Range("AF" & Idx1)
Next Idx1
件数 = k
ActiveWorkbook.Close
Next i
End Function
'*---------------------------------------------------------------------------------*
Function 配列の内容をシートに記入_11()
Workbooks("RCM受払.xlsm").Worksheets("入荷集計表").Activate
行 = 3
For i = 0 To 件数
If AR(i, 0) <> "" Then
If AR(i, 8) <> 0 And AR(i, 6) <= wkDate Then
行 = 行 + 1
For j = 1 To 9 'B列:P列
Cells(行, j) = AR(i, j)
Next
Cells(行, 10) = AR(i, 0)
End If
End If
Next
最終行 = 行
End Function

'----------------------------------------------------------------------------------------*

質問者からの補足コメント

• Qchan1962様
  
  追記がありました。
  先ほどのマクロは拡張子を .xlsm にしても正常に動作しています。
  
  よろしくお願いいたします。

  No.6の回答に寄せられた補足コメントです。 補足日時：2022/12/09 10:47

• Function 個別Bookの内容を配列に格納_11() '合計の行をFIND関数で検索する　　Do～Loopは時間がかかるため
  Dim Idx1 As Integer
  k = -1
  For i = 0 To 1999
  If FAR(i) = "" Then Exit For
  Workbooks.Open Filename:=FAR(i), UpdateLinks:=0 '外部リンクを表示しない
  For Idx1 = 7 To 1000
  If Range("C" & Idx1) = "" Then
  Exit For
  End If
  
  続きを次の補足に書きます。

  No.16の回答に寄せられた補足コメントです。 補足日時：2022/12/22 10:20

• k = k + 1
  AR(k, 0) = FAR(i)
  AR(k, 1) = Range("E1")
  AR(k, 2) = Range("M2")
  AR(k, 3) = Range("C2")
  AR(k, 4) = Range("H2")
  AR(k, 5) = Range("C3")
  AR(k, 6) = Range("B" & Idx1)
  AR(k, 7) = "'" & Range("C" & Idx1)
  　　　　AR(k, 8) = Format(Range("Z" & Idx1), 0)
  　　　　AR(k, 9) = "'" & Range("AF" & Idx1)
  
  続きを次の補足に書きます

    補足日時：2022/12/22 10:23

• Next Idx1
  件数 = k
  ActiveWorkbook.Close
  Next i
  End Function
  
  ここの構文でVBAが落ちてしまいます。
  各ブックをオープンしてデータをひろっています。
  Nextから戻って、何回かは動いていますが、突然落ちてしまいます。
  何回もすみません。

    補足日時：2022/12/22 10:26

No.17 ベストアンサー 回答者： Qchan1962 回答日時： 2022/12/23 20:52

#16の補足について

繰り返しになりますが、　FIND関数は使われていません・・何を取得したいのでしょうか？

初心者と言う事で判らなことも多いと思いますが
補足について
＞Dim FAR(1999), AR(1999, 9)
配列ARのサイズは1999，9です　　600ファイル程度あると言う事ですが
０と１９９９　2000/600　１ファイルでおおよそ3行しか取得する事は出来ませんが　For Idx1 = 7 To 1000　となっています

If Range("C" & Idx1) = "" Then　となっていますが、
For Idx1 = 7 To Range("C7").End(xlDown).Row
If Range("C" & Idx1) = "" Then　要らない
Exit For　要らない
End If　要らない
となると思います (平均4行未満は保証されませんが)

また、
AR(k, 1) = Range("E1")
AR(k, 2) = Range("M2")
AR(k, 3) = Range("C2")
AR(k, 4) = Range("H2")
AR(k, 5) = Range("C3")
について何度も同じセルを参照する場合は、変数に代入してセルへのアクセスを減らすべきです
最大3000回に減らせます（600ファイル）

セルに書き込む
For j = 1 To 9 'B列:P列
Cells(行, j) = AR(i, j)
Next
Cells(行, 10) = AR(i, 0)
End If
これについて考えるなら配列AR作成段階でインデックスを適正にすれば
1つずつ書き込む必要はなく処理時間、リソースを減らせると思います

FIND関数を使用する・・ループの回数、同じセルへの参照などから
目的が不明な為　評価できません

このロジックの正しい結果をお知らせ頂ければ簡素化できるものと思います
（想像：合計と言う文字列がC列にありその行の各列の値を取得したい
１行目～３行目の取得セルにはブック（データ）の情報が入っているので
合わせて取得したい）

Workbooks.Openでの不具合は＃１様が示されている通りです

ExcelBookに問題がある場合、リネーム、コピーコマンドなどを行っても問題は解決できないと思います

Excelの互換設定をオプションで設定して開ける事が前提になりますが、
すべてのBookを1ファイルずつ開き　新しいブックに移して（作り直して）行く必要があると思います。リネームやコピーは不具合もコピーされます
（メソッドや関数などの不具合は改善、更新できません）

＃１３のコードは試されましたか？
リンク先のアクセスはできないようにしましたが　試すのであれば　返信してください。制限解除します

複数のフォルダに纏められているようですが、各フォルダを対象に実行するなど手作業が必要です
処理時間はPCスペックで変わると思いますが・・シート数、モジュール数も少ないようですので10ファイル　数秒だと思います

No.16 回答者： Qchan1962 回答日時： 2022/12/21 18:18

FileSearch2007については＃15に示した通りですが

何処でスタックしているかお分りですか？

私が勘違いしたようで
2007からは大分時間がたちますが、使えていたと言う事ですね
.xlsmに変更したら使えなくなったで間違いないですかね

Workbooks.Openにブレークポイントを設けて実行してみてください
またはF8キーでステップ実行で確かめてください

その他の場所に疑いがある場合は
各　End Function　の上行に stop　を書き込み異常なく止まるごとに
F5を押す、どのプロシージャでスタックするか調べる

煩雑になってしまいましたので
スタックしているプロシージャを示して別質問を建てるのが良いと思います

ファイルの作り直しは試したかな？

ご質問には関係ない所ですが
合計の行をFIND関数で検索する　　Do～Loopは時間がかかるため
FIND関数は使われていないようですが？
もっともここなどは動いていたと解釈してスルーしますね

この回答へのお礼

Qchan1962様

何回も本当にありがとうございます。

FileSearch2007について、初心者なりに再度確認したところ、問題無く動いていました。
他の部分で落ちてしまうことも何となく分かってきたのですが、原因が全くわかりません。

お礼日時：2022/12/22 10:11

No.15 回答者： Qchan1962 回答日時： 2022/12/19 15:56

こんにちは

Set found_file = FileSearch2007(target_path, target_extention)について本ご質問に記されていませんが
https://oshiete.goo.ne.jp/qa/13272697.html　を検証しました

変数や参照設定が不明の為、完結できるように宣言等を加えましたので
ご確認ください（テスト用で抽出件数でMsgが出ます）
テストは新しい標準モジュールで

Option Explicit
Dim FAR(1999), AR(1999, 9), ゼロ表示, 件数, 最終行
Dim wkDate As Date
Function パス名Book名を配列ARに格納_11()
Dim i As Long, k As Long
Dim target_path As String, target_extention As String
Dim found_file As Object
k = -1
target_path = ThisWorkbook.Path
target_extention = UCase("xlsm")
Set found_file = FileSearch2007(target_path, target_extention)
件数 = found_file.Count
'------テスト用
MsgBox "取得ファイル件数：" & 件数 & " 件"
'------
If 件数 = 0 Then
MsgBox "*.xlsmファイルがないため処理を終了します。"
End
End If
For i = 1 To 件数
If Right(found_file(i), 10) <> "フォーマット.xlsm" And _
Right(found_file(i), 7) <> "在庫表.xlsm" Then
k = k + 1
FAR(k) = found_file(i)
End If
Next
End Function
Function FileSearch2007(dir_path, target_extention)
Dim found_files As Object
Set found_files = New Collection
Call FileSearch2007_Repeat(dir_path, found_files, target_extention)
Set FileSearch2007 = found_files
End Function
Private Sub FileSearch2007_Repeat(dir_path, found_files, target_extention)
Dim fso As Object
Dim target_folder As Object
Dim sub_folder As Object, objFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set target_folder = fso.GetFolder(dir_path)
For Each sub_folder In target_folder.SubFolders
Call FileSearch2007_Repeat(sub_folder.Path, found_files, target_extention)
Next sub_folder
For Each objFile In target_folder.Files
With objFile
If ((UCase(fso.GetExtensionName(.Path))) = target_extention) Then
found_files.Add Item:=.Path
End If

No.14 回答者： Qchan1962 回答日時： 2022/12/19 01:15

FileSearchについてApplication.FileSearch と勘違いをしてしまっていたようですみません

しっかり再帰処理のファンクションが書かれていれば問題ないと思います
お詫び致します

No.13 回答者： Qchan1962 回答日時： 2022/12/16 19:53

古いブックを新しいブックに書き換えるコードも書いて見ます

ブックに問題がある場合試してみてください
処理時間がかかると思いますので10ファイルぐらいで試すおうにして下さい
リンクは好みませんが、仕方ない

https://ideone.com/XGUIFH

No.12 回答者： Qchan1962 回答日時： 2022/12/16 18:30

FileSearch2007 は　使用出来ませんので＃５のコードに代替します

＞古いエクセルファイルのシート数は・・
　ファイル数になりますが、600ファイルありました。

ファイルはブックを指すものと思われますが　そのブックの中にあるシートは　1シートなのでしょうか・・・CSVファイルから加工したようなもの？
複数シートがある場合（コードにないので１シートだと思いますが）対象のデータシートが開いた時に表示されている必要が出て来ます

①古いエクセルファイルのシート数は

②Function 並び替え_11() は同じモジュールに書かれていますか？

③処理中に開く対象ブックのマクロは使わないですよね

並び替え_11()を除くコードを書いて見ます

新しいモジュールを追加して　すべてのコードをコピペ
P11New_フォルダ内容書出し　を実行
シート初期化・対象ファイルのあるフォルダ選択・処理
下記にUPしました

https://ideone.com/dcwZY0

エラーなどが出た場合、内容をお知らせください

また、古いブックを新しいブックに書き換えるコードも書いて見ますので
しばらくお待ちください　
（名前・リンクのあるファイルの対応は少し難しいかも）

この回答へのお礼

Qchan1962様

いろいろとありがとうございます。
お尋ねいただいた項目についてお答えします。

＞①古いエクセルファイルのシート数は
　一つです。

＞②Function 並び替え_11() は同じモジュールに書かれていますか？
　同じモジュールでした。
入荷集計表の構文の順番です。

1. Sub P11_フォルダ内容書出し()
2. Function 記入済データを消去_11()　
3. Function パス名Book名を配列ARに格納_11()
4. Function 個別Bookの内容を配列に格納_11() '合計の行をFIND関数で検索する　　Do～Loopは時間がかかるため
5. Function 配列の内容をシートに記入_11()
6. Function 並び替え_11() 'B:得意先、C:鋼材メーカー、G:商社順に並び替える
7. Function 進度表示_11()

＞③処理中に開く対象ブックのマクロは使わないですよね
　使っていません。
　対象ブックのマクロは単純にデータの並び替えのみに使用しています。

何回もすみません。

どうかよろしくお願いいたします。

お礼日時：2022/12/20 17:07

No.11 回答者： Qchan1962 回答日時： 2022/12/14 15:18

こんにちは　

話の流れで遠回りしてしまったかも知れません　私のスキル不足でかえって時間を使わせてしまって申し訳ないです
＞何回やっても動きませんでした。
説明が無かったですね

＃８＃９＃10のコードを同じ標準モジュールにコピペして
Sub P11_フォルダ内容書出し()を実行

検証は対象をミニマムに
デスクトップなどにフォルダを作り対象ファイルを（２ファイル程度）コピペして置き試してみてください　（表示されるFolderPickerで作ったファルダを選択）

整理してみます
事象　Excelが落ちる
①エラー番号、落ちる前の実行コード不明
②FileSearch2007が使えない
多分　No.5対策でOK
③古いエクセルファイル（マクロブック）を拡張子を変え.xlsmにした
作り直していないがエクセル365で実行できる

疑問
1　①はステップ実行などで確認できないでしょうか
2　実行プロシージャの　進度表示_11　並び替え_11　はどこに記されているのでしょう　
3　古いエクセルファイル（対象ファイル）のVBAは全ファイル同じで並び替えだけですか
4　古いエクセルファイルのシート数は・・

③が原因だった時
古いエクセルファイルを新しいExcelブックに同名で作り直す（VBA）
（各ブックの状態が知りたい　すべて共通か　シート数、各モジュールの使用の有無、図や画像の有無　など　ある場合は詳細が必要かも　グループ化やタイプ）

VBAで作り直す事はやった事があるのでどこかにしまっていると思いますが
互換モードを使用しないとならない場合、一部不具合があったような記憶があります　保護パスワードやグループ図や画像が無ければ良いのですが・・

この回答へのお礼

Qchan1962様
いろいろとご助言ありがとうございます。

>1　①はステップ実行などで確認できないでしょうか？
　F8で行ったところ、FileSearch2007 が記述された標準モジュールで止まっています。動きはよくわかりませんが、この記述を読みに行くのかもしれません。

>2　実行プロシージャの　進度表示_11　並び替え_11　はどこに記されているのでしょう？
　以下のような記述があり、構文が記されていました。かなり長いので、ここでは書ききれませんでした(泣)
　　　↓
　Function 並び替え_11() 'B:得意先、C:鋼材メーカー、G:商社順に並び替える

＞3　古いエクセルファイル（対象ファイル）のVBAは全ファイル同じで並び替えだけですか
　その通りです。全て同じフォーマットを使用しています。
　
＞4　古いエクセルファイルのシート数は・・
　ファイル数になりますが、600ファイルありました。

よろしくお願いいたします。

お礼日時：2022/12/16 16:32

No.10 回答者： Qchan1962 回答日時： 2022/12/09 18:57

Sub 個別Bookの内容を配列に格納_11()

Dim Idx1 As Integer, k As Long, i As Long, n As Integer
k = -1
For i = 0 To UBound(FAR)
If FAR(i) = "" Then Exit For
With Workbooks.Open(Filename:=FAR(i), UpdateLinks:=0)
n = n + 1
With Worksheets(1)
For Idx1 = 7 To 1000
If .Range("C" & Idx1) = "" Then
Exit For
End If
If FAR(i) <> "" Then
'Findの条件？
If .Range("Z" & Idx1) <> 0 And .Range("B" & Idx1) <= wkDate Then
k = k + 1
AR(k, 0) = .Range("E1")
AR(k, 1) = .Range("M2")
AR(k, 2) = .Range("C2")
AR(k, 3) = .Range("H2")
AR(k, 4) = .Range("C3")
AR(k, 5) = .Range("B" & Idx1)
AR(k, 6) = "'" & .Range("C" & Idx1)
AR(k, 7) = Format(.Range("Z" & Idx1), "0.0")
AR(k, 8) = "'" & .Range("AF" & Idx1)
AR(k, 9) = FAR(i)
End If
End If
Next Idx1
End With
.Close False
End With
Next i
'配列の内容をシートに記入_11()
aggSht.Cells(4, 1).Resize(UBound(AR, 1) + 1, UBound(AR, 2) + 1) = AR
'最終行 = 行
MsgBox n & " ファイル　" & k + 1 & "件抽出"
End Sub

Sub exControl(flag As Boolean)
With Application
.DisplayAlerts = flag
.ScreenUpdating = flag
.EnableEvents = flag
End With
End Sub

この回答へのお礼

ありがとうございます。

いただいた構文をコピペして試していましたが、何回やっても動きませんでした。

私のスキルが Qchan1962 様のご助言に達していないのが原因だと思います。

直接、このVBAを含めたエクセルファイル全てを見ていただければと思うのですが、何か良い方法はおありでしょうか。

何回も申し訳ありません。

お礼日時：2022/12/14 14:03

No.9 回答者： Qchan1962 回答日時： 2022/12/09 18:56

Sub パス名Book名を配列ARに格納_11()

Dim filePath()
Dim k As Long, i As Long
Dim folPath As String, f As String
Dim Path As String, Wsh As Variant
Set Wsh = CreateObject("WScript.Shell")
Path = Wsh.SpecialFolders("Desktop")
Set Wsh = Nothing
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "ファイルの入っているフォルダを選択して下さい"
.ButtonName = "選択"
.InitialFileName = Path & "\R在庫表\R関係在庫表"
If .Show = 0 Then Exit Sub
folPath = .SelectedItems(1)
End With
f = Dir(folPath & "\*." & UCase("xls*"))
Do While f <> ""
If InStr(f, "フォーマット.xlsm") = 0 And _
InStr(f, "在庫表.xlsm") = 0 Then
FAR(k) = folPath & "\" & f
k = k + 1
End If
f = Dir
Loop
If k = 0 Then
MsgBox "ファイルが見つかりません": Exit Sub
Else
Call 個別Bookの内容を配列に格納_11
End If
End Sub

No.8 回答者： Qchan1962 回答日時： 2022/12/09 18:55

Findの条件気になりますね

ファイル群　For Idx1 = 7 To 1000　　AR(1999, 9)　
オーバーフローしないのかな・・

コードだと上手く投稿できないので分けます
標準モジュールを追加するなどして確かめてください

Option Explicit
Dim FAR(1999), AR(1999, 9)
Dim ゼロ表示, 件数 As Long, 最終行 As Long
Dim wkDate As Date
Dim ThisBook As Workbook, aggSht As Worksheet
Sub P11_フォルダ内容書出し()
Set ThisBook = ActiveWorkbook
Set aggSht = ThisBook.Worksheets("入荷集計表")
Call exControl(False)
Call 記入済データを消去_11
'進度表示_11
Call パス名Book名を配列ARに格納_11
'並び替え_11
Call exControl(True)
End Sub

Sub 記入済データを消去_11()
Dim msg As String, msg_rt As Variant
With aggSht
msg = "シート「入荷集計表」を最新の状態に更新します。実行しますか？"
msg_rt = MsgBox(msg, vbYesNo)
If msg_rt <> vbYes Then End
If .Range("B4") <> "" Then '?
.Rows("4:" & .Cells(.Rows.Count, "B").End(xlUp).Row).Clear
End If
If IsDate(.Range("G2")) Then
wkDate = CDate(.Range("G2"))
Else
wkDate = CDate("2060/12/31")
End If
End With
End Sub