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

質問

皆様お世話になります。
あるフォルダーの下位にユニークに名前の付けられた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.27

ham_kamo

> St3 = Mid(St, Start:=x + 1, Length:=y - x - 1)
> が反転表示されています。

う～ん、セル分割されてるっぽいですねえ。多分 ) が見つからないのかな。

だめ押しで、

Workbooks.OpenText ThisWorkbook.Path & "\" & FILE2, _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1))

としてみても同じでしょうか。

もし差し支えなければ、うまくいかない行を１行でいいので、
Z2PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;
でなくて、形状コードをそのままにした形で書いていただけませんか？
こちらでは「セル分割されてしまう」というのが再現しなくて、調べようがないので。

お礼

ありがとうございます。
今回は、エラー発生はありませんでした。
手動で確認したところ、正しく開いておりました。
NG行
Z18PC(SO-T20H11-E )PN()SZ0SC()VP(77000,-700)VH0AN1JN1;
OK行
Z2PC(3216C09E )PN()SZ0SC()VP(-266810,-1280)VH-2500AN1JN1;
念のため何かの時に役立てばと思い載せておきます。
あと、お願いがまた出まして。すみません。
エラーログが出るので、いちいち確認しなくても良いようにならないでしょうか。あと、ログの形式をA列にZ表　B列に検索文字列として出していただけると嬉しいのですが。　一度走らせた結果として100弱のエラーが発生してるみたいなのです。
どうかよろしくお願いいたします。

回答No.26

ham_kamo

ログを出力する部分です。Sheet2に出力します。
まず、

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

の下に、

　'ログシート準備
　Set L = ThisWorkbook.Worksheets("Sheet2")
　L.Cells.ClearContents
　L.Cells(1, 1) = "実行日時：" & Format(Date, "yyyy/mm/dd") & " " & Format(Now, "hh:mm:ss")
　l1 = 3 'ログシートの行番号

を追加してください。
そして、

　If MsgBox("NC(" & TMPFILE2 & ")がみつかりません。続行しますか？", _

の直前に、

　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

を追加してください。

最後に、

　'データをソート
　Application.StatusBar = "データソート中..."

の直前に、

　If l1 = 3 Then
　　L.Cells(l1, 1) = "エラーファイルなし"
　End If

を挿入してください。

エラーがあった場合はZ表のファイル名とNCファイルの検索文字列を表示し、エラーがなかった場合は「エラーファイルなし」とSheet2に出力されます。

回答No.25

ham_kamo

すみません、書き間違えました。
Workbooks.OpenText ThisWorkbook & "\" & FILE2, DataType:=xlFixedWidth

でなくて、
Workbooks.OpenText ThisWorkbook.Path & "\" & FILE2, DataType:=xlFixedWidth

でした。これで試してみていただけますか？
ログの部分はまた後で回答します。

お礼

ありがとうございます。
Workbooks.OpenText ThisWorkbook.Path & "\" & FILE2, DataType:=xlFixedWidth
にした場合でもエラー発生です　実行時エラー５　プロシージャの呼び出し、または引数が不正です。　デバックでは
St3 = Mid(St, Start:=x + 1, Length:=y - x - 1)
が反転表示されています。

回答No.24

ham_kamo

> １つはNCを開いた時に、いくらかのファイルのみ
> 区切られて読み込まれると言う現象がおきます
> Z2PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;
> Z4PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;

不思議ですね。。。
Workbooks.OpenText でファイル名しか指定しないと、デフォルトで DataType := xlDelimited で、区切り文字は特に指定しない限り「なし」となるので区切られるはずはないのですが…。

ためしに、以下のように固定長ファイルの指定をしてファイルをオープンしてみたらどうなりますか？
Workbooks.OpenText ThisWorkbook & "\" & FILE2, DataType:=xlFixedWidth

ちなみにソースを読む限り、これは、「形状コードを探す」というコメントのあるところで、
Z2PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;
でZとPの間の2（これがZno？）がZ表と一致したら、()内の文字列を取りだしてC列に入れている、だけど )P の前でセルが区切られるので形状コードが取得できない、ということで私の理解はあっているでしょうか？、

> ２つめはnc(******)が見つかりません　続行しますかとなった場合ＯＫと
> するとインデックスが有効範囲にありません　で停止となり

すみません、これは考慮漏れです。ファイルが見つからなくてオープンしてないのにクローズしようとしていました。
最後の方に、

　Loop
End If
'NCファイルを閉じる
Workbooks(FILE2).Close SaveChanges:=False

とあるところの順序を入れ替えて、

　Loop
　'NCファイルを閉じる
　Workbooks(FILE2).Close SaveChanges:=False
End If

としてください。

> もし可能ならエラーログを最後にテキストで表示されると確認できるのですが
> 可能でしょうか？

というのは、NCファイルが見つからなかったときのログでしょうか。
ログを出力するのは可能ですが、エラーログの内容はどのようにしましょうか。

エラーが発生したファイル
Z表：VEAxxxxx-DR.xls
NCファイル検索文字列:"Dxxxxx*S-*DR"

みたいな感じで出力すればよいでしょうか。

それで、エラーログはどこに表示しますか？別途テキストファイルをオープンしてログファイルとして出力することもできるし、マクロのブックの他のシートに書き出すこともできます。（後者の方が当然簡単ですが）

お礼

ありがとうございます。
Workbooks.OpenText ThisWorkbook & "\" & FILE2, DataType:=xlFixedWidth
を入れてみましたが、実行時エラー438　オブジェクトはこのプロパティまたはメソッドをサポートしていません　と出て怒られました。
Z　No　や　エラー内容は推測された通りです。
エラーログは他シートに書き出す方法でお願いします。
表示は記入していただいた内容で結構です。

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

回答No.23

ham_kamo

> Z表にありNCに無い場合

とありますが、実際のシート構成がわからないので、「NCに無い場合」というのが具体的にどういうNCファイルのどのセルがどうなっている場合かこちらにはわかりません。ので、また勘で答えます。

ロジックから想像すると、
St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)

でエラーが出るということは、
１．Stの値が不正
２．x + 1 の値が不正
３．y - x- 1 の値が不正
のいずれかが考えられます。

Stは、
St = s.Cells(m, 1)

で定義していますが、このループの条件が、
Do Until s.Cells(m, 1) = "" Or z = 1

となっているので、Stが空文字列ということはあり得ません。

一方、x と y の値は直前の
x = InStr(St, "Z")
y = InStr(St, "P")

から持ってきているので、エラーの原因として

Stが空文字列でないのに、"Z"のあるいは"P"の文字がない。もしくは、"P"が"Z"より前にある。

と考えられます。
「Z表にありNCに無い場合」
というのは、そういうことでしょうか？

> 無い場合は強制的に"NG"か何かを書けるようにしていただけると
> ありがたいですが・・・・空白のままでもいいです

えと、これはMsgBoxで「Z=XXXがNCファイルにありません。続行しますか？」といちいちダイアログを出すのでなく、
r.Cells(n, 3) = "NG"
というようにして、そのまま続行させる、ということでしょうか。

一応、そういうことだと解釈して、手直しをしてみました。
まず、以下の範囲

St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)

If Trim(St2) = Trim(r.Cells(n, 1)) Then
　x = InStr(St, "(")
　y = InStr(St, ")")
　z = 1

　St3 = Mid(St, Start:=x + 1, Length:=y - x - 1)
　r.Cells(n, 3) = St3
End If

この部分を以下のようにIf～Thenで囲みます。
If x <> 0 And y <> 0 Then
　St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)

　If Trim(St2) = Trim(r.Cells(n, 1)) Then
　　x = InStr(St, "(")
　　y = InStr(St, ")")
　　z = 1

　　St3 = Mid(St, Start:=x + 1, Length:=y - x - 1)
　　r.Cells(n, 3) = St3
　End If
End If

そして、その下の

If MsgBox("Z=" & r.Cells(n, 1) & "がNCファイル(" & FILE2 & ")に見つかりません" & _
vbCrLf & "続行しますか？", vbYesNo, "NCファイルエラー") = vbNo Then
Workbooks(FILE2).Close SaveChanges:=False
MsgBox ("処理を中断しました。")
Exit Sub

を全部カットして、

r.Cells(n, 3) = "NG"

に置きかえます。

以上を修正して試していただけますか？

お礼

おはようございます。　ありがとうございます。
凄いです。エラーも回避され問題なく動作し結果も１つ１つ行った物と一緒になりました。現在最終確認として多くのファイルの処理を実行しています。結果をまた報告させていただきます。

補足

お世話になっています。
現状２つほどありまして。
１つはNCを開いた時に、いくらかのファイルのみ　区切られて読み込まれると言う現象がおきます
Z2PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;
Z4PC(****************)PN()SZ0SC()VP(333333,3333333)VH0AN1JN1;
の様に並んでいるのですが　)Pの前部分で区切られるのです。
一応回避するためWorkbooks.OpenText Filename:=ThisWorkbook.Path & "\" & FILE2, DataType:=xlDelimited, semicolon:=True
として最後のセミコロンで区切るにしました。結果としてはＯＫなのですがまだ異なる場所で区切られているみたいです。
フォーマットはＯＫの物もＮＧの物もテキスト上では同じにしか見えません。
２つめはnc(******)が見つかりません　続行しますかとなった場合ＯＫとするとインデックスが有効範囲にありません　で停止となり
'NCファイルを閉じる
Workbooks(FILE2).Close SaveChanges:=False
が反転しています。その次のnextまで動かせば　処理は続行されます。
ファイル自体は本当に存在しない場合とファイル名が条件に一致しないのいずれかです。もし可能ならエラーログを最後にテキストで表示されると確認できるのですが　可能でしょうか？
どうかよろしくお願いします

回答No.22

ham_kamo

マクロの中のロジックとなると、実際のデータシートがないので、半分勘で答えます。

> 2枚目を開けに行ったときにエラー
> If Trim(s.Cells(n, Zno(m) + 2)) <> "" Then
> で止まります。

は、mを初期化してないからだと思います。
その前の
Do Until m = t - 1
の上に、
m = 0
を入れればいいかと思います。

そして

> それと、Z表にありNCに無い場合先にエラーで停止します

これも同じ理由かと思います。先のループでmが初期化されてないので、２回目のループで、
r.Cells(p, 1) = s.Cells(n, Zno(m)) 'Zno
のmに狂いが出て、間違ったセルの値がセットされてしまうのだと思います。

とりあえず、上記の m = 0 を入れて試していただけますか？

補足

ありがとうございます　早速実施しました。結果として　問題の無いファイルでは複数まとめて処理してもエラー発生はありませんでした。
しかし、Z表にありNCに無い場合では同じようにエラー発生にて停止しました。実行時エラー５
プロシージャの呼び出し　または引数が不正です
St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)

無い場合は強制的に"NG"か何かを書けるようにしていただけるとありがたいですが・・・・空白のままでもいいです。

回答No.21

ham_kamo

NCファイルのファイル名はもうちょっとややこしかったのですね。ただ、最終的なファイル名の判断基準が、

> ４　ファイルの判断基準としてDから"-"の2つ前までが同じでなおかつ最後のDR,SRが一致する事が必要となります
>　Z表のファイル名の最後がDRの場合は"-"の前がSとなり　SRの場合はRとなります

で絞り込めるのなら、途中をワイルドカード（*）で指定することによってファイル名を取得できるかと思います。

まず、

FILE2 = "D" & Mid(FILE1, 4, InStr(1, FILE1, "-") - 4) & _
Mid(FILE1, InStr(1, FILE1, "-") + 1, 2)

の部分を、

DR_or_SR = Mid(FILE1, InStr(1, FILE1, "-") + 1, 2)
S_or_R = IIf(DR_or_SR = "DR", "S", "R")
TMPFILE2 = "D" & Mid(FILE1, 4, InStr(1, FILE1, "-") - 4) & _
"*" & S_or_R & "-*" & DR_or_SR
FILE2 = Dir(ThisWorkbook.Path & "\" & TMPFILE2)

に差し替えて、その次の

'NCデータを探す
If Dir(ThisWorkbook.Path & "\" & FILE2) = "" Then
　If MsgBox("NC(" & FILE2 & ")がみつかりません。続行しますか？", _

の部分を、

If FILE2 = "" Then
　If MsgBox("NC(" & TMPFILE2 & ")がみつかりません。続行しますか？", _

に変更してみてください。

補足

お世話になりありがとうございます。あともう少しのような気がしてきました。もうしばらくのお付き合いをお願いいたします。
先ほどの変更で、基本動作はOKと思います。NC　1ファイル　Z表１ファイルにてテストした結果は　前のマクロと同じ結果となりました。
そのまま、ループでそれぞれ2つにした時にエラーが発生しました。
2枚目を開けに行ったときにエラー
If Trim(s.Cells(n, Zno(m) + 2)) <> "" Then
で止まります。

それと、Z表にありNCに無い場合先にエラーで停止します
よろしくお願いします。

St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)
無理やり次のステップまで持っていくとメッセージが出てNCに無いよと言ってくれます（そのときの内容は正しい）そのまま走らせると次のループでもエラーとなります。その時は両ファイルには在るのに。ncに無いよ　表示が出現します。

回答No.20

ham_kamo

すみません、目論見を誤りました。
せめてダミーファイルを用意して少し処理を流すべきでした。

先ほど修正をお願いした、
Set s = Workbooks(FILE1).Worksheets(1).Range("A1:A3000")
Set s = Workbooks(FILE2).Worksheets(1).Range("A1:A3000")
は、
Set s = Range("A1:A3000")
に戻してください。

そして、最初のSet文の３行上にある
FILE1 = .FoundFiles(j)
を、
FILE1 = Dir(.FoundFiles(j))
に変更してください。

まだまだ不具合は出るかもしれませんが、とりあえず上記を修正して試していただけますか？

補足

ありがとうございます。遅くなり申し訳ありません
Z表の写しを行う部分までは、問題なく動作しているように思います。（元ファイルを動かした時と同じ状態）次のファイルを探しに行ったときにファイル名が違うため、「NCファイルエラー」となります。
'NCファイル名をZ表のファイル名から求める
FILE2 = "D" & Mid(FILE1, 4, InStr(1, FILE1, "-") - 4) & _
Mid(FILE1, InStr(1, FILE1, "-") + 1, 2)
この時に作成されたファイルの名称が（D******SR)で存在しているファイル名が(D*******-*-SR)という名称のファイルです。
一致する条件を自分なりに考えた結果をまとめますとFILE2の名称として
１　Dのあと5桁の数字はFILE1と一致します
２　D12345のあと2～3桁がアルファベットになっており2桁の場合は1桁目がバージョンになり3桁の場合は2桁目までがバージョンとなります
３　D******A-*-SRのため　DからA-までの間は一致し　AもしくはSの場合は最後がDR　となりRもしくはBの場合はSRとなっています。
４　ファイルの判断基準としてDから"-"の2つ前までが同じでなおかつ最後のDR,SRが一致する事が必要となります
　Z表のファイル名の最後がDRの場合は"-"の前がSとなり　SRの場合はRとなります

色々書いてわけが分からないかも知れませんが、なにとぞよろしくお願いします。

回答No.19

ham_kamo

> 次のSet s = Range("A1:A3000")で止まります。
> ウオッチでは値が対象範囲外　型はemptyです

どうやら work.xls にコピーして開き直すところを省略した副作用が出てしまったようです。

Set s = Workbooks(FILE1).Worksheets(1).Range("A1:A3000")

に変更してみてください。

同様にNCファイルを開いたあとも、
s = Range("A1:A3000")
があるので、そこも
Set s = Workbooks(FILE2).Worksheets(1).Range("A1:A3000")
にしていただけますか？

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

すみません、ここの「エラーは400だけ出て停止」の意味がよくわかりません。
・エラーの数が400個出るのでしょうか。それとも「400」という番号のエラーが出るのでしょうか。
・エラーメッセージは正確には何と出てますか？
・あと、「停止」というのはマクロの特定の行が黄色くなって止まった状態ですか？その場合、どの行で止まったのでしょうか。
以上を補足願えますか？

> 今回頂いたものを新しく起こしたBOOKの
> 標準モジュールに貼り付け場合はk=0の部分で止まりました。

いろいろな方法で試されているようですが、

・元のマクロファイルのThisWorkbookにマクロを記述した場合、マクロを手動で実行した場合
→　Set s = Range("A1:A3000")　で止まる

・元のマクロファイルのThisWorkbookにマクロを記述した場合、マクロをボタンから実行すると、
→　「エラーは400だけ出て停止」の状態になる

・新しく起こしたBOOKの標準モジュールに貼り付けた場合は
→　k=0の部分で止まる。

ということですよね。

k=0の部分で止まるのは、多分Option Explicitが設定されているので、Dimでkが宣言されていないのでエラーになるのでしょう。一番上にOption Explicitと書かれていたら削除してください。

それで、マクロを見た限り、標準モジュールに書いてもThisWorkbookに書いてもいいような気がするのですが、もともとThisWorkbookにあって正常に動いていたのだったら、そこに書いた方がいいかもしれませんね。（普通は標準モジュールに作りますが）

> 左側にあるプロジェクトウインドウ？にはfuncres(FUNCRES.xls)というものが

それはエクセルの「分析ツール」アドオンを追加したときにできるモジュールです。分析ツールの機能をマクロで使用してないのであれば、特に気にする必要はありません。

補足

ありがとうございます。
Set s = Range("A1:A3000")をSet s = Workbooks(FILE1).Worksheets(1).Range("A1:A3000")に変更しましたが　同じく実行時エラーが発生し同じメッセージで止まります。
Workbooks(FILE1)をウォッチしますと<インデックスが有効範囲にありません。>と出ています。
　手動で動かした時ですが正確にはSet s = Range("A1:A3000")が反転表示しているわけではなく　f8で１つずつ動かした時に先ほどの位置まで行った時にエラー発生となります。何処かが反転表示していることはありません。

400のエラーの件ですが、ボタンを押した後　メッセージウインドウが出て400と出ています赤丸の×がが付いた状態です。OK　ヘルプのボタンが出ます　ヘルプ押してもVBのヘルプウインドウが開くだけで何も表示されません。

つたない内容を理解していただきありがとうございます。

回答No.18

ham_kamo

修正したマクロです。

Sub link_shape_cell()
　Dim Zno(20) As Integer

　k = 0
　j = 0

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

　'Z表を探す
　'csvファイルを探す
　With Application.FileSearch
　　.LookIn = ThisWorkbook.Path
　　.Filename = "VEA*.xls"
　　If .Execute = 0 Then
　　　MsgBox "Ｚ表がみつかりません。処理を中断します。"
　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False

　　'全てのZ表についてループで処理する
　　For j = 1 To .FoundFiles.Count
　　　FILE1 = .FoundFiles(j)
　　　Application.StatusBar = j & "ファイル目：" & FILE1 & " 処理中"
　　　Workbooks.Open Filename:=ThisWorkbook.Path & "\" & FILE1, Format:=2
　　　Set s = Range("A1:A3000")

　　　'現行ファイルの末尾を探す
　　　p = IIf(r.Cells(1) = "", 1, r.Cells(r.Count).End(xlUp).Row + 1)
　　　p_org = p

　　　'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
　　　'CSVファイルを閉じる
　　　Workbooks(FILE1).Close SaveChanges:=False

　　　'NCファイル名をZ表のファイル名から求める
　　　FILE2 = "D" & Mid(FILE1, 4, InStr(1, FILE1, "-") - 4) & _
　　　Mid(FILE1, InStr(1, FILE1, "-") + 1, 2)

　　　'NCデータを探す
　　　If Dir(ThisWorkbook.Path & "\" & FILE2) = "" Then
　　　　If MsgBox("NC(" & FILE2 & ")がみつかりません。続行しますか？", _
　　　　vbYesNo, "NCファイルエラー") = vbNo Then
　　　　　MsgBox ("処理を中断しました。")
　　　　　Exit Sub
　　　　End If
　　　Else
　　　　Workbooks.OpenText Filename:=ThisWorkbook.Path & "\" & FILE2, comma:=False
　　　　Set s = Range("A1:A3000")
　　　　m = 1
　　　　k = 0
　　　　Do Until s.Cells(m, 1) = "" Or k <> 0
　　　　　Select Case Trim(s.Cells(m, 1))
　　　　　　Case "MACHINE=MPAV", "MACHINE=MV2F", "MACHINE=MV2C"
　　　　　　　MACHINE = Replace(Trim(s.Cells(m, 1)), "MACHINE=", "")
　　　　　　　k = 1
　　　　　End Select
　　　　　m = m + 1
　　　　Loop

　　　　m = 1
　　　　k = 0
　　　　Do Until s.Cells(m, 1) = "" Or k <> 0
　　　　　If Trim(s.Cells(m, 1)) = "%SETUP" Then 'NCファイルから"%SETUP"を探す
　　　　　　k = m
　　　　　End If
　　　　　m = m + 1
　　　　Loop

　　　　'形状コードを探す
　　　　n = p_org
　　　　Do Until r.Cells(n, 1) = ""
　　　　　r.Cells(n, 6) = MACHINE
　　　　　m = k + 1 '"%SETUP"の次の行
　　　　　z = 0
　　　　　Do Until s.Cells(m, 1) = "" Or z = 1
　　　　　　St = s.Cells(m, 1)

　　　　　　x = InStr(St, "Z")
　　　　　　y = InStr(St, "P")

　　　　　　St2 = Mid(St, Start:=x + 1, Length:=y - x - 1)

　　　　　　If Trim(St2) = Trim(r.Cells(n, 1)) Then
　　　　　　　x = InStr(St, "(")
　　　　　　　y = InStr(St, ")")
　　　　　　　z = 1

　　　　　　　St3 = Mid(St, Start:=x + 1, Length:=y - x - 1)
　　　　　　　r.Cells(n, 3) = St3
　　　　　　End If

　　　　　　m = m + 1
　　　　　Loop
　　　　　If z = 0 Then
　　　　　　If MsgBox("Z=" & r.Cells(n, 1) & "がNCファイル(" & FILE2 & ")に見つかりません" & _
　　　　　　vbCrLf & "続行しますか？", vbYesNo, "NCファイルエラー") = vbNo Then
　　　　　　　Workbooks(FILE2).Close SaveChanges:=False
　　　　　　　MsgBox ("処理を中断しました。")
　　　　　　　Exit Sub
　　　　　　End If
　　　　　End If
　　　　　n = n + 1
　　　　Loop
　　　End If
　　　'NCファイルを閉じる
　　　Workbooks(FILE2).Close SaveChanges:=False
　　Next
　End With

　'データをソート
　Application.StatusBar = "データソート中..."
　ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Sort _
　Key1:=Range("B1"), Header:=xlNo, OrderCustom:=1
　'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
　Application.StatusBar = ""
　MsgBox "処理終了です"

End Sub