ファイル全てを .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.7 回答者： Qchan1962 回答日時： 2022/12/09 17:58

こんにちは

Sub 並べ替え()については記録マクロで不要と思われる部分もありますが
問題はないと存じます
しかし、拡張子変更に伴いブック自体に問題があるかも知れません
対象ブック群を新規ブックにコピペするVBAなどで作り直す必要があるかも知れませんね（やり方は色々ありますが元ブックはあるかな？）

ご質問にあるコードですが、疑問があります
Workbooks.Openで開いたブックには1シートしかないのでしょうか？
For j = 1 To 9 'B列:P列
Cells(行, j) = AR(i, j)
Next
Cells(行, 10) = AR(i, 0)
End If
かなりのデータ数を書き込んでいるようですが　AR作成時に工夫して
ARを一度に出力した方が処理の負担が減ると思います

＞'合計の行をFIND関数で検索する　　Do～Loopは時間がかかるため
FIND見当たらないのですが・・

ご質問のコードを添削して条件に合ったデータを書き出すコードを作ってみますね（不明なところはコメント）

No.6 回答者： Qchan1962 回答日時： 2022/12/07 18:44

＃５です

拡張子変更による不具合についてですが
Workbooks.Open Filename:=FAR(i), UpdateLinks:=0
ここにブレークポイントを設置して実行
到達すればファイルパスは取得できていると思います
その後　F8キーでステップイン　Workbooks.Open　でスタックするようであれば　（値の取得だけのようなので）
該当Excelファイルのマクロを無効又は削除して実行してみてください
状況によってはコピーファイルを拡張子xlsxに変更してとか
互換モードで開くなど試してみてはいかがでしょう
（簡単なマクロも入っています）使うのかな？
該当しないかもですが
https://answers.microsoft.com/ja-jp/msoffice/for …

この回答へのお礼

Qchan1962さん
ありがとうございます。
いろいろと助かります。

エクセル2000で作成したマクロが入っている.xls ファイルですが、
今のエクセル365でも動作しています。
単純に中のデータを在庫があるものを数量が大きい順に
並び替えるマクロが入っています。
どうしてもこの機能は必要なので使用しています。
昔、記録したマクロです。
何か問題はありそうでしょうか？

Option Explicit

Sub 並べ替え()
'
' 並べ替え Macro
' マクロ記録日 : 2007/8/28 ユーザー名 : S
'

'
ActiveWindow.SmallScroll Down:=-3
Range("A7:AF7").Select
ActiveWindow.SmallScroll Down:=27
Range("A7:AF45").Select
Selection.Sort Key1:=Range("AD6"), Order1:=xlDescending, Key2:=Range("Z7" _
), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
ActiveWindow.SmallScroll Down:=-63
ActiveWindow.SmallScroll ToRight:=-3
Range("D7").Select
End Sub

お礼日時：2022/12/09 10:45

No.5 回答者： Qchan1962 回答日時： 2022/12/07 18:08

＞"C:\Users\ユーザーアカウント名\Desktop\R在庫表\R関係在庫表\顧客名\メーカー名\素材合計\素材名\素材ファイル.xlsm"

このファイル決め打ちなら
Function パス名Book名を配列ARに格納_11()は要らないと思いますよ
コードに不備があったので一応書き直します
拡張子変更による不具合は検討していません
FileSearch2007の代替えコードです
Function パス名Book名を配列ARに格納_11()
Dim found_file()
Dim target_path As String, target_extention As String
Dim k As Long, f As String, i As Long
Dim Path As String, Wsh As Variant
Set Wsh = CreateObject("WScript.Shell")
Path = Wsh.SpecialFolders("Desktop") & "\"
Set Wsh = Nothing

target_path = Path & "\R在庫表\R関係在庫表\顧客名\メーカー名\素材合計\素材名"
target_extention = UCase("xlsm")
f = Dir(target_path & "\*." & target_extention)
Do While f <> ""
ReDim Preserve found_file(k)
found_file(k) = target_path & "\" & f
k = k + 1
f = Dir
Loop
If k = 0 Then
MsgBox "*.xlsmファイルがないため処理を終了します。"
End
End If
For i = 0 To UBound(found_file)
If Not InStr(found_file(i), "フォーマット.xlsm") > 0 And _
Not InStr(found_file(i), "在庫表.xlsm") > 0 Then
FAR(i) = found_file(i)
End If
Next
End Function

この回答へのお礼

ありがとうございます。
何回も申し訳ありません。
やはり途中で落ちてしまいます。

＞"C:\Users\ユーザーアカウント名\Desktop\R在庫表\R関係在庫表\顧客名\メーカー名\素材合計\素材名\素材ファイル.xlsm"

顧客名以下の階層フォルダですが、実際にはいろいろな名称になっています。
素材合計 というフォルダ名だけは共通の階層とフォルダ名です。

例えば

"C:\Users\ユーザーアカウント名\Desktop\R在庫表\R関係在庫表\A社\B工業\素材合計\SUS301H\0.2x500.xlsm"

上記のようになっています。

お礼日時：2022/12/09 14:36

No.4 回答者： tatsumaru77 回答日時： 2022/12/07 17:35

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

どのようにして拡張子を.xlsmに変えたのでしょうか。
単純にエクスプローラとかコマンドプロンプトで、ファイル名の拡張子を変えただけではおかしくなります。

No.3 回答者： Qchan1962 回答日時： 2022/12/07 12:52

＃２です・・

間違えちゃった
For i = 0 To 件数 - 1
If Not InStr(found_file(i), "フォーマット.xlsm") > 0 And _
Not InStr(found_file(i), "在庫表.xlsm") > 0 Then
k = k + 1
FAR(k) = found_file(i)
End If
Next
は　下記に変更してください

For i = 0 To 件数 - 1
If Not InStr(found_file(i), "フォーマット.xlsm") > 0 And _
Not InStr(found_file(i), "在庫表.xlsm") > 0 Then
FAR(i) = found_file(i)
End If
Next


使用箇所
For i = 0 To 1999
If FAR(i) = "" Then Exit For
Workbooks.Open Filename:=FAR(i)
0スタートでOK

この回答へのお礼

ありがとうございます。
書き換えてみたのですすが、デバッグになってしまい先に進みません。

フォルダ階層が深くなっていましたので、訂正いたします。

"C:\Users\ユーザーアカウント名\Desktop\R在庫表\R受払.xlsm"

このプログラムを使って、

"C:\Users\ユーザーアカウント名\Desktop\R在庫表\R関係在庫表\顧客名\メーカー名\素材合計\素材名\素材ファイル.xlsm"

を検索して別の集計表に反映するプログラムです。

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

No.2 回答者： Qchan1962 回答日時： 2022/12/07 12:44

こんにちは

FileSearch2007　って　確かファイルパスも含まれていた気が・・
Workbooks.Open Filename:=FAR(i)
ですね

単純にThisWorkbook.Path同階層でDirを使って
Function パス名Book名を配列ARに格納_11()を変えると

Function パス名Book名を配列ARに格納_11()
Dim found_file()
Dim k As Long

target_path = ThisWorkbook.Path
target_extention = UCase("xlsm")

f = Dir(target_path & "\*." & target_extention)
Do While f <> ""
ReDim Preserve found_file(k)
found_file(k) = target_path & f
k = k + 1
f = Dir
Loop
件数 = UBound(found_file) + 1
If 件数 = 0 Then
MsgBox "*.xlsmファイルがないため処理を終了します。"
End
End If
For i = 0 To 件数 - 1
If Not InStr(found_file(i), "フォーマット.xlsm") > 0 And _
Not InStr(found_file(i), "在庫表.xlsm") > 0 Then
k = k + 1
FAR(k) = found_file(i)
End If
Next
End Function

取り合えず試していませんが・・

No.1 回答者： ogi_3 回答日時： 2022/12/07 12:38

.xlsmに変更したことが原因なら、元に戻すしか対処法は無いと思います。