エクセルでのファイル名の一括変更 マクロ

質問

皆様お世話になります。
あるフォルダーの下位にユニークに名前の付けられた900個ほどのフォルダーがあり
それれぞれの、フォルダーの中にA,Bというフォルダーがあります。
その中にa.xls，b.xlsなどというファイルが存在しています。

そのa.xlsやb,xlsの名称を変換したいのですが数量が非常に多いためマクロか、何かで変更する方法がありますか？

ファイル名の条件として　開いたエクセルのC,4とH,4を合体させたファイル名にすると、非常にありがたいのですが。
よろしくお願いします。

回答No.28

ham_kamo · ベストアンサー

うまく読み込めたようでよかったです。あと一息ですね。

まず、ダイアログを出さないようにする変更点ですが、以下の、

　If MsgBox("NC(" & TMPFILE2 & ")がみつかりません。続行しますか？", _
　vbYesNo, "NCファイルエラー") = vbNo Then
　 MsgBox ("処理を中断しました。")
　 Exit Sub
　End If

をまるまるカットしてください。

そして、ログの書式変更ですが、このすぐ上の、

　If l1 = 3 Then
　 L.Cells(l1, 1) = "エラーが発生したファイル"
　 l1 = l1 + 1
　End If
　L.Cells(l1, 1) = "Ｚ表：" & FILE1
　L.Cells(l1 + 1, 1) = "NCファイル検索文字列：" & TMPFILE2
　l1 = l1 + 3

を、

　If l1 = 3 Then
　 L.Cells(l1, 1) = "エラーが発生したファイル"
　 L.Cells(l1 + 1, 1) = "Ｚ表"
　 L.Cells(l1 + 1, 2) = "NC検索文字列"
　 l1 = l1 + 2
　End If
　L.Cells(l1, 1) = FILE1
　L.Cells(l1, 2) = TMPFILE2
　l1 = l1 + 1

に置きかえてください。（ログシートの列の幅は適当に調節してください）

お礼

本当にありがとうございます。無事に完了しログも整理しやすい状態となりました。マクロは出来ると本当に便利ですね。少しぐらい出来るように頑張らないといけませんね。　今回のご協力いただいた内容を少しぐらいは理解出来るように頑張りたいと思います。
ありがとうございました。

回答No.17

ham_kamo

わけあって暇なので、元のマクロも解析して修正してみました。

主な変更点は、
・VEA*.xlsで検索し、見つかったZ表全てについてループでまわし、ループの中でZ表のファイル名を元にNCファイル名を特定して処理をするようにした。

・Z表、NCファイルともに、いったんテキストで読み込んでからwork.xlsという名前で保存し、改めて開き直している意図がわからなかったので、開いたCSVファイルからそのままセルの値を参照してCloseするようにした。（どうみてもsでRangeを取得してCellsでセル参照しているだけなので、SaveChange:=FalseでClosesしているし、問題はないはず）

・高速化のために処理中は描画を停止している。ただし進行状況を左下のステータスバーに表示するようにした。

・その他の部分は基本的にいじってないが、書き方を簡略化できるところは手直ししている。

しかし、私の手元にデータファイルがないので、全くテストはしておりません。構文エラーがないことだけ確認していますが、まず一発でうまくいくとは思ってないので、とりあえず元のファイルのバックアップをとっておき、私の書いたマクロに置きかえて動かしてみていただけますでしょうか。

マクロは長いので次の回答でアップします。

お礼

おはようございます。本当にありがとうございます。！！
朝から教えていただいた内容を、本を見ながら確認していたのですが
全くもって手足が出ない状態でどうしようかと、悩んでいた所でした。
直ちにテストを実施して報告させていただきますので　どうかよろしくお願いします。

補足

すみません。動作結果としては「アプリケーション定義またはオブジェクトの定義エラーです」実行時エラー1004
Application.StatusBar = j & "ファイル目：" & FILE1 & " 処理中"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & FILE1, Format:=2
次のSet s = Range("A1:A3000")で止まります。
ウオッチでは値が対象範囲外　型はemptyです

ただ、もともとのBOOKのシート1にボタンが設置してあり　それを押した時のエラーは400だけ出て停止します。

それと、元ファイルを見ますとマクロ自体が「This Workbook」に書かれてあり　左側にあるプロジェクトウインドウ？にはfuncres(FUNCRES.xls)というものが存在してありそれはpassで保護されています。
今回頂いたものを新しく起こしたBOOKの標準モジュールに貼り付け場合はk=0の部分で止まりました。

回答No.16

ham_kamo

> "H4"を取り込んだその前に"-"を入れるため
> Replace(("-") & Worksheets(1).Range("H4").Value, "/", "") & ".xls"
> として"-"を入れることが出来ました。"

えっと、その書き方でも文法的には通るのですが、「何をやっているか？」という可読性を考えると、

"-" & Replace(Worksheets(1).Range("H4").Value, "/", "") & ".xls"

の方がいいですね。

それで、この行は前の行からの続きなのですが、その前の行の

Cells(i, "D") = Worksheets(1).Range("C4").Value & _

の箇所を修正しようとしたのですよね。この２行がうまくつながるように処理しないと、エラーの原因となってしまいます。

Excelのファイル名を、
「C4のセルから","を抜いた文字列」-「H4のセルから"/"を抜いた文字列」.xls
とするには、

.Cells(i, "D") = Worksheets(1).Range("C4").Value & _
Replace(Worksheets(1).Range("H4").Value, "/", "") & ".xls"

の２行を、以下のように修正してみてください。

.Cells(i, "D") = Replace(Worksheets(1).Range("C4").Value, ",", "") & _
"-" & Replace(Worksheets(1).Range("H4").Value, "/", "") & ".xls"

それから、

> それとなぜか幾つかのファイルが変更を保存しますか？
> と聞いてきますが、すべてNOで返したいのですが・・・・

これはシートの中に、開くたびに自動計算される関数（TODAY()など）があると、何も変更してなくてもダイアログが出てしまうのだと思います。これに対処するために、上で修正した行の次にある、
Workbooks(Workbooks.Count).Close
を、
Workbooks(Workbooks.Count).Close SaveChanges:=False
に変えてみてください。

お礼

ありがとうございます。なるほど可読性というものも考えないといけないのですね。　とりあえず結果がそうなれば・・・と思うものですから。
全て順調に動いております。　残りは元々のマクロの改造なのですが一向に理解できていないようで・・・・

回答No.15

ham_kamo

> フォルダ直下にエクセルファイルがあるフォルダが１つだけで動作っせると…

こちらでも現象を確認しました。修正を加えたので、以下の部分を置きかえていただけますか？

まず、マクロの先頭の方の
Dim D As Object, F As Object
の下に、
Dim Folders As Range
を追加してください。

そして、最後から２つめの大きなブロック、
　i = 1: j = 1
　For Each R In Union(Range("A1", Cells(Rows.Count, "A").End(xlUp)), _
　Range("B1", Cells(Rows.Count, "B").End(xlUp)))
　　For Each F In FSO.GetFolder(RootPath & R.Value).Files
　　　　　　　：
　　　　　　　：
　　　i = i + 1: j = j + 1
　　Next
　Next

の箇所を、

　i = 1: j = 1
　If Range("A1") <> "" Then
　　Set Folders = Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　If Range("B1") <> "" Then
　　　Set Folders = Union(Folders, Range("B1", Cells(Rows.Count, "B").End(xlUp)))
　　End If
　　For Each r In Folders
　　　For Each F In FSO.GetFolder(RootPath & r.Value).Files
　　　　Application.StatusBar = j & "ファイル処理中"
　　　　Cells(i, "C").Value = r.Value & F.Name
　　　　If StrConv(F.Name, vbLowerCase) Like "*.xls" Then
　　　　　With ActiveSheet
　　　　　　Workbooks.Open (RootPath & Cells(i, "C").Value)
　　　　　　.Cells(i, "D") = Worksheets(1).Range("C4").Value & _
　　　　　　Replace(Worksheets(1).Range("H4").Value, "/", "") & ".xls"
　　　　　　Workbooks(Workbooks.Count).Close
　　　　　End With
　　　　Else
　　　　　Cells(i, "D").Value = F.Name
　　　　End If
　　　　i = i + 1: j = j + 1
　　　Next
　　Next
　End If

に置きかえてみてください。

お礼

書き換え完了しました。　ありがとうございます。
動作問題なしです。

回答No.14

ham_kamo

> で現在開発していただいているマクロで名前を変更し
> 1つのフォルダーに集めファイル名を元に一度に
> 処理できないでしょうか？

これは補足していただいたマクロを手直しすればできると思いますよ。
With Application.FileSearch
.LookIn = ThisWorkbook.Path
.Filename = "Q*.xls"
If .Execute > 0 Then
If .FoundFiles.Count > 1 Then
MsgBox "Ｚ表が複数あります"
Else

のところの"Q*.xls"というのが、名前が変更されているのならそれにマッチする検索文字列に変更し（このマクロのブックと、名称変更のマクロのブックが検索対象にならないように気をつけてください）、
For i = 1 to .FoundFiles.Count
BookName = .FoundFiles(i)
　：
　：
Next
のようにループでまわせばいいと思います。

ただし、その後のテキストファイルの検索でもFileSearchを使ってますが、１つのExcelファイルにつき１つのテキストファイルをオープンして処理もするのであれば、その処理を上のループの中に入れないといけません。

しかしここで、FileSearchのループの中でFileSearchを使うと.FoundFilesが壊れてしまうので、テキストファイルの検索でFileSearchは使えません。

もし、名称変更したExcelのファイル名や、セルの値からファイル名を特定して決め打ちで指定できるのなら、FileSearchを使わず
if Dir(テキストファイル名) = "" Then エラー
のようにDir関数でファイルの存在確認をしてから、直接オープンするように修正すればいいかと思います。

お礼

だめです　さっぱり分かりません。エクセルは今回のマクロでVEA******-DRみたいな感じになりました。テキストはD*****で最後がDR　という感じになっており共通部分は*****の部分と最後の2桁が共通しています

回答No.13

ham_kamo

> うまく動かない理由わかりました。H4から取り込んだ
> 部分にスラッシュが存在しているためのようです。　

そうでしたか！いや、これは想定外でした。
H4から抜き出すときに"/"を""に置換してからファイル名としてC4と結合するように変更してみました。

Worksheets(1).Range("H4").Value & ".xls"

という行（Ctrl+Fで"H4"で検索して見つけてください）を、

Replace(Worksheets(1).Range("H4").Value, "/", "") & ".xls"

に変更して、ファイル名一覧作成を再度実行し、シートに表示されたファイル名を確認していただけますか？

スラッシュがファイル名に含まれていないようなら、「ファイル名の変更と移動」が動いてくれるはず、です。

お礼

ありがとうございます。無事に動作しました。また元に戻す方も動作問題なさそうです。　１つ気になることが　フォルダ直下にエクセルファイルがあるフォルダが１つだけで動作っせると　フォルダと同じ位置あるマクロを開こうとします。　既に開いています・・・・のメッセージが出ますが・・・フォルダ＞フォルダ＞エクセルの物が一緒にあるとその様な、ことはありません。　また、シートの対象箇所が空白の場合　.xlsというファイルを作成します。複数ある場合は、同じファイル名があるといって停止となります。　こんなのも回避できますでしょうか？　お願いばかりで申し訳ありません。

補足

度々申し訳ありません。"H4"を取り込んだその前に"-"を入れるためReplace(("-") & Worksheets(1).Range("H4").Value, "/", "") & ".xls"として"-"を入れることが出来ました。"C4"の部分に","があるためそれも無くそうと同じようにしてみたのですが　エラーとなってしまいました。それとなぜか幾つかのファイルが変更を保存しますか？と聞いてきますが、すべてNOで返したいのですが・・・・
","を無くすことでテキストファイルのD*******Aと変換したファイル名はVEA******-DRと言うようになり左から3つ後の6つと右側から2つで各ファイルが判別可能になるのですが・・・

回答No.12

ham_kamo

せっかくマクロの内容を補足欄に転記していただいたので、ちょっと拝見してみました。長いのと表の構成などがわからないので、実際の処理のところはあまり見てません。しかし、手動でファイルを移動して実際に今処理ができているのなら問題はないでしょう。

ただ１つ気になったのが、

With Application.FileSearch
.LookIn = ThisWorkbook.Path
.Filename = "Q*.xls"
If .Execute > 0 Then
If .FoundFiles.Count > 1 Then
MsgBox "Ｚ表が複数あります"
Else

及び、
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeAllFiles
If R.Cells(p - 1, 4) = "S/R" Then
.Filename = "D*SR*"
ElseIf R.Cells(p - 1, 4) = "D/R" Then
.Filename = "D*DR*"
End If
If .Execute > 0 Then
If .FoundFiles.Count > 1 Then
MsgBox "NCが複数あります"
Else

の部分です。"Q*.xls"が２つ以上あったら、あるいは"D*SR*"または"D*DR*"が２つ以上あったら、メッセージボックスを出して処理は行われないですよね。

フォルダーの下の全てのファイルを、マクロが動くフォルダーに集めてしまうと、ここの処理に影響が出ませんか？

お礼

ありがとうございます。
そうなのです。1つのフォルダーに1対しか置けないので　いちいちファイルを動かして動作させないといけない内容になっています。そこで現在開発していただいているマクロで名前を変更し1つのフォルダーに集めファイル名を元に一度に処理できないでしょうか？と考えているのですが・・・・・？どうでしょう？

回答No.11

ham_kamo

続いてエラーが出る件です。
これはデバッグしてみないとわからないので、お手数ですが下記の手順にしたがってデバッグしていただけますでしょうか。

１．ファイル名の変更と移動()　の中の、
Name FName As RootPath & R.Offset(0, 1).Value
の行（エラーが出る行）を選択してF9を押してください。
行全体がえんじ色になって、左に●がつくはずです。
（ブレークポイントをそこに設定しました）

２．その行の FName の部分をマウスで選択し、右クリックから「ウォッチ式の追加」を選択し、OKを押してください。下のウォッチウィンドウに FName が追加されるはずです。
ウォッチウィンドウが開いてないときは、「表示」＞「ウォッチウィンドウ」で開いてください。

３．同じくその行の RootPath & R.Offset(0, 1).Value という部分を選択し、同様にウォッチ式の追加を行ってください。

４．その状態でF5キーを押すと、そのプロシージャが実行され、ブレークポイントを設定したその行で実行が中断されます。（行が黄色く反転します）
そこで、ウォッチ式に追加した２つの式の「値」を確認していただきたいのです。「値」の欄が短くて収まりきってない場合は、表示された値をダブルクリックするとその値をマウスで選択できるので、それを端から端までコピーして、メモ帳にでも貼り付ければ見やすくなります。

それで、表示された「FName」の値（移動するファイル名）が正しいか、実際に存在するかを確認してください。
２つめの RootPath & R.Offset(0, 1).Value の方は移動後のファイル名で、これはまだ存在していないはずですが、何かおかしな文字列になってないか、などを一応確認していただけますか？

確認したら、その実行中のマクロはツールバーの■マークを押して中止してください。

補足

おはようございます。重ね重ねありがとうございます。
うまく動かない理由わかりました。H4から取り込んだ部分にスラッシュが存在しているためのようです。　形式としてはS/R,D/Rの2パーターンと思われますが、このときにスラッシュを消して取り込むことは可能でしょうか？。後　下記は結合するマクロの最後の部分です。

'データをソート
ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
'B行とC行が同じものを抹消する
z = 1
Do Until r.Cells(z, 1) = ""
q = z + 1
Do Until r.Cells(q, 2) <> r.Cells(z, 2)
If r.Cells(q, 3) = r.Cells(z, 3) Then
Rows(q).Select
Selection.Delete Shift:=xlToUp
Else
r.Cells(z, 2).Interior.ColorIndex = 27
r.Cells(q, 2).Interior.ColorIndex = 27
q = q + 1
End If
Loop
z = z + 1
Loop

ThisWorkbook.Save

MsgBox "処理終了です"

End Sub

回答No.10

ham_kamo

「ファイル名一覧作成」はうまくいったようですね。とりあえずよかったです。

> いったん　この質問を閉めた方が良いでしょうか？

いえ、新規の質問にすると私も今までの流れがわかりにくくなるので、このまま行きましょう。（回答で作成したマクロに、この質問の場合だと Q2846325.xls という名前をつけて保存しているのですが、質問番号が変わるとそのファイルを探すのに手間がかかってしまうので）

それで、このサイトでは質問者が回答者に何か伝えたいとき、１つの回答につきお礼欄と補足欄１つずつしか使えず、これを使い切ってしまうと回答者に伝える手段がなくなってしまいます。そのため、「お礼欄」「補足欄」を多めに確保するために、ちょっと細切れに回答します。この回答はとりあえずここまでとして、次はエラーが出る件について回答します。

回答No.9

ham_kamo

続いて「ファイル名の変更と移動」のエラーの件です。

おそらくフォルダ名が違っているのかと思うのですが、「整理番号を元に型番と品番と結びつけるマクロ」が動くフォルダ（ファイルを集めるフォルダ）と、このマクロが動くフォルダが同じであるのであれば、あえてマクロ内にフォルダー名を指定する必要がないので、
「ファイル名の変更と移動」
「ファイル名を元に戻して元のフォルダに移動」
のマクロをそのように書き換えてみました。ついでにエラーチェックもしています。これで試していただけますか？
（自分で作っておきながら、長ったらしいマクロ名にしてしまい、後悔しています。マクロ名は動作に支障ないので、Sub の後の名前はご自分で分かりやすいように適当に変えていただいでもかまいません）

Sub ファイル名の変更と移動()
　Dim RootPath As String, FName As String
　Dim R As Range
　RootPath = ThisWorkbook.Path & "\"
　With Worksheets("Sheet1")
　　If .Range("A1") = "" Then Exit Sub
　　For Each R In .Range("C1", Cells(Rows.Count, "C").End(xlUp))
　　　FName = RootPath & R.Value
　　　If Dir(FName) = "" Then
　　　　If MsgBox(FName & vbCrLf & "がありません" & vbCrLf & vbCrLf & _
　　　　"OK→続行/キャンセル→中断", vbOKCancel, "名前変更エラー") = vbCancel Then
　　　　　Exit Sub
　　　　End If
　　　Else
　　　　Name FName As RootPath & R.Offset(0, 1).Value
　　　End If
　　Next
　End With
End Sub

Sub ファイル名を元に戻して元のフォルダに移動()
　Dim RootPath As String, FName As String
　Dim R As Range
　RootPath = ThisWorkbook.Path & "\"
　With Worksheets("Sheet1")
　　If .Range("A1") = "" Then Exit Sub
　　For Each R In .Range("C1", Cells(Rows.Count, "C").End(xlUp))
　　　FName = RootPath & R.Offset(0, 1).Value
　　　If Dir(FName) = "" Then
　　　　If MsgBox(FName & vbCrLf & "がありません" & vbCrLf & vbCrLf & _
　　　　"OK→続行/キャンセル→中断", vbOKCancel, "名前変更エラー") = vbCancel Then
　　　　　Exit Sub
　　　　End If
　　　Else
　　　　Name FName As RootPath & R.Value
　　　End If
　　Next
　End With
End Sub

お礼

ここと、下の補足に使うマクロを写してみます
Sub link_shape_cell()

Dim Zno(20) As Integer

'ThisWorkbook.Worksheets("Sheet1").Range("A1:Z3000").Clear
k = 0
j = 0

'このファイルにデータをコピー
ThisWorkbook.Worksheets("Sheet1").Activate
Set r = Range("A1:A3000")

'現行ファイルの末尾を探す
p = 1
Do Until r.Cells(p, 1) = ""
p = p + 1
Loop

p_org = p

'Z表を探す
'csvファイルを探す
With Application.FileSearch
.LookIn = ThisWorkbook.Path
.Filename = "Q*.xls"
If .Execute > 0 Then
If .FoundFiles.Count > 1 Then
MsgBox "Ｚ表が複数あります"
Else
Workbooks.Open Filename:=.FoundFiles(1), Format:=2
'もとのファイルを閉じて、エクセルファイルに写し変える
ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\work.xls"
ActiveWorkbook.Close Filename:=.FoundFiles(1)

補足

ありがとうございます
しかしながら　同一のエラー発生します　エクセルは2002なのですが

回答No.8

ham_kamo

なるほど、だいたいわかりました。
とりあえず、c:\temp\z\ にこのマクロを置いても大丈夫（c:\temp\z\A の直下にエクセルがあってもOK）なように修正しました。

あと、各列の幅も文字列にあわせて調整するようにしました。

「ファイル名一覧作成」のマクロだけ、以下のマクロに差し替えていただけますか？

Sub ファイル名一覧作成()
　Dim RootPath As String
　Dim i As Integer, j As Integer
　Dim R As Range
　Dim FSO As Object
　Dim D As Object, F As Object

　Set FSO = CreateObject("Scripting.FileSystemObject")
　RootPath = ThisWorkbook.Path & "\"

　Application.ScreenUpdating = False
　Worksheets("Sheet1").Unprotect
　Worksheets("Sheet1").Activate
　Cells.ClearContents

　i = 1: j = 1
　For Each D In FSO.GetFolder(RootPath).SubFolders
　　Application.StatusBar = j & "フォルダ処理中"
　　Cells(i, "A").Value = D.Name & "\"
　　i = i + 1: j = j + 1
　Next

　i = 1
　For Each R In Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　For Each D In FSO.GetFolder(RootPath & R.Value).SubFolders
　　　Application.StatusBar = j & "フォルダ処理中"
　　　Cells(i, "B").Value = R.Value & D.Name & "\"
　　　i = i + 1: j = j + 1
　　Next
　Next

　i = 1: j = 1
　For Each R In Union(Range("A1", Cells(Rows.Count, "A").End(xlUp)), _
　Range("B1", Cells(Rows.Count, "B").End(xlUp)))
　　For Each F In FSO.GetFolder(RootPath & R.Value).Files
　　　Application.StatusBar = j & "ファイル処理中"
　　　Cells(i, "C").Value = R.Value & F.Name
　　　If StrConv(F.Name, vbLowerCase) Like "*.xls" Then
　　　　With ActiveSheet
　　　　　Workbooks.Open (RootPath & Cells(i, "C").Value)
　　　　　.Cells(i, "D") = Worksheets(1).Range("C4").Value & _
　　　　　Worksheets(1).Range("H4").Value & ".xls"
　　　　　Workbooks(Workbooks.Count).Close
　　　　End With
　　　Else
　　　　Cells(i, "D").Value = F.Name
　　　End If
　　　i = i + 1: j = j + 1
　　Next
　Next

　Set FSO = Nothing
　Columns("A:D").EntireColumn.AutoFit
　Worksheets("Sheet1").Protect
　Application.StatusBar = ""
　Application.ScreenUpdating = False
　MsgBox ("完了しました")
End Sub

長くなるので、いったんこの回答はここまでにして、「ファイル名の変更と移動」でエラーが出る件は次に回答いたします。とりあえず「ファイル名一覧作成」で一覧が正常に出るか確認していただけますでしょうか。

お礼

ありがとうございます！！
　無事動作いたしました。　いったん　この質問を閉めた方が良いでしょうか？新規で質問あげた方がよろしければそのようにいたしますが？。

補足

'エクセルファイルを開く
Workbooks.Open Filename:=ThisWorkbook.Path & "\work.xls"
Set s = Range("A1:A3000")

'Znoの列を探す
q = 1
t = 0
Do Until s.Cells(7, q) = "" And s.Cells(7, q + 1) = "" And s.Cells(7, q + 2) = "" And s.Cells(7, q + 3) = ""
If Trim(s.Cells(7, q)) = "ＺNo" Then
Zno(t) = q
t = t + 1
End If
q = q + 1
Loop
'必要なデータを転記する
n = 8
Do Until m = t - 1
n = 8
Do Until n = 27
If Trim(s.Cells(n, Zno(m) + 2)) <> "" Then
r.Cells(p, 1) = s.Cells(n, Zno(m)) 'Zno
r.Cells(p, 2) = s.Cells(n, Zno(m) + 2) '品番
r.Cells(p, 5) = s.Cells(4, 3) '機種
r.Cells(p, 4) = s.Cells(4, 8) 'D or S
p = p + 1
End If
n = n + 1
Loop
m = m + 1
Loop
End If
'エクセルファイルを閉じる
Application.CutCopyMode = False
Workbooks("work.xls").Close SaveChanges:=False

End If
End With
'探すファイル名を決定する　キーは数字
FILE = r.Cells(p - 1, 5)
xx = 20
yy = 0
For i = 0 To 9

If InStr(FILE, i) <> 0 Then
x = InStr(FILE, i)
If xx > x Then
xx = x
End If
End If
If InStrRev(FILE, i) <> 0 Then
y = InStrRev(FILE, i)
If yy < y Then
yy = y
End If
End If
Next i

FILE2 = Mid(FILE, Start:=xx, Length:=yy - xx + 1)

'NCデータを探す

'NCファイルを探す
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeAllFiles
If r.Cells(p - 1, 4) = "S/R" Then
.Filename = "D*SR*"
ElseIf r.Cells(p - 1, 4) = "D/R" Then
.Filename = "D*DR*"
End If
If .Execute > 0 Then
If .FoundFiles.Count > 1 Then
MsgBox "NCが複数あります"
Else
If InStr(.FoundFiles(1), FILE2) <> 0 Then 'ファイルとZ表が正しいかどうかチェック
Workbooks.OpenText Filename:=.FoundFiles(1), comma:=False
'もとのファイルを閉じて、エクセルファイルに写し変える
ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\work.xls"
ActiveWorkbook.Close Filename:=.FoundFiles(1)