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

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

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

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

No.18 回答者： ham_kamo 回答日時： 2007/03/23 08:34

修正したマクロです。

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

No.17 回答者： ham_kamo 回答日時： 2007/03/23 08:26

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

主な変更点は、
・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の部分で止まりました。

補足日時：2007/03/23 09:29

この回答へのお礼

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

お礼日時：2007/03/23 08:52

No.16 回答者： ham_kamo 回答日時： 2007/03/22 16:05

> "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
に変えてみてください。

この回答へのお礼

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

お礼日時：2007/03/22 18:04

No.15 回答者： ham_kamo 回答日時： 2007/03/22 12:00

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

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

まず、マクロの先頭の方の
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

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

この回答へのお礼

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

お礼日時：2007/03/22 12:26

No.14 回答者： ham_kamo 回答日時： 2007/03/22 11:01

> で現在開発していただいているマクロで名前を変更し

> 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桁が共通しています

お礼日時：2007/03/22 21:02

No.13 回答者： ham_kamo 回答日時： 2007/03/22 10:36

> うまく動かない理由わかりました。

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

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

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

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

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

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

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

この回答への補足

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

補足日時：2007/03/22 13:25

この回答へのお礼

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

お礼日時：2007/03/22 10:55

No.12 回答者： ham_kamo 回答日時： 2007/03/22 09:54

せっかくマクロの内容を補足欄に転記していただいたので、ちょっと拝見してみました。

長いのと表の構成などがわからないので、実際の処理のところはあまり見てません。しかし、手動でファイルを移動して実際に今処理ができているのなら問題はないでしょう。

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

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つのフォルダーに集めファイル名を元に一度に処理できないでしょうか？と考えているのですが・・・・・？どうでしょう？

お礼日時：2007/03/22 10:08

No.11 回答者： ham_kamo 回答日時： 2007/03/22 09:34

続いてエラーが出る件です。

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

１．ファイル名の変更と移動()　の中の、
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

補足日時：2007/03/22 09:52

No.10 回答者： ham_kamo 回答日時： 2007/03/22 09:10

「ファイル名一覧作成」はうまくいったようですね。

とりあえずよかったです。

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

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

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

No.9 回答者： ham_kamo 回答日時： 2007/03/21 22:46

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

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

この回答への補足

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

補足日時：2007/03/21 23:43

この回答へのお礼

ここと、下の補足に使うマクロを写してみます
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)

お礼日時：2007/03/22 00:07