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

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

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

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

No.1 回答者： Rich53 回答日時： 2007/03/20 01:01

小生がいつもやっている手ですが、

DOSpromptにて、ディレクトリをとります。
それを、excelで開いて、エクセル画面上で修正、
DOS batch fileを作ります。
具体的に

DOS promptにて、該当フォルダ”あるフォルダ”をカレントとします。
手順は、DOS promptの画面で、まず、
>C:リターン
>cdスペース
と打って、その一方で、エクスプローラを開いて、”あるフォルダ”をドラッグしてDOS prompt画面に持ってきます。
>cd C:\xxxxxxxxxxxxxxxxxxxxxxxx\あるフォルダ　　リターン
これで、”あるフォルダ”をカレントにできました。
次に、
>dir /s/b/o >mylist.txt
と打ちます。

エクセルからmylist.txtを開く
エクセル画面にて
ren oldname newname
oldname ----- 絶対パスです。
newnameも絶対パスとします。

と言った感じで、編集します。newnameは、「C,4とH,4を合体させたファイル名」
最後に、saveasで、DOS(tab)で保存します。
エクスプローラにて、ファイル名を　mylist.batに変更します。
mylist.batをダブルクリックすれば、バッチファイルが動作します。
尚、実行前にバックアップを取っておいてください。

この回答へのお礼

ありがとうございます。
ちょっと私には、敷居が高いように思います

お礼日時：2007/03/20 07:40

No.2 回答者： Dxak 回答日時： 2007/03/20 01:02

エクセルマクロで、実施する理由は何でしょうか？

Vector
Download: Windows > ユーティリティ > ファイル管理 > ファイル名変更:
http://www.vector.co.jp/vpack/filearea/win/util/ …

みたいに、フリーソフトで、たくさんありますが・・・

データベース化したいとか？
別のデータで名前を参照して書き換えたいとか？

この回答へのお礼

ありがとうございます。
お察しのとおり、別データで名前を参照して中身の特定部分を使用し対のです。

お礼日時：2007/03/20 07:42

No.3 回答者： Dxak 回答日時： 2007/03/20 11:11

モジュール的には、そんなに難しいものでは、ありません

ファイル名の一覧を取得するモジュールは、作成してませんが・・・

Sub usFileReName()
On Error Resume Next

Dim I As Long
Dim usBePath, usBeName As String
Dim usAfPath, usAfName As String

I = 2

With ActiveSheet
usBePath = .Cells(I, 1)
usBeName = .Cells(I, 2)
usAfPath = .Cells(I, 3)
usAfName = .Cells(I, 4)
While usBePath & usBeName <> ""
If Dir(usBePath & "\" & usBeName) = "" Then
.Cells(I, 5) = "File Not Found"
Else
If Dir(usAfPath & "\" & usAfName) = "" _
And usAfPath & usAfName <> "" Then
Name usBePath & "\" & usBeName As usAfPath & "\" & usAfName
.Cells(I, 5) = "File ReName Complete"
Else
.Cells(I, 5) = "File Not ReName"
End If
End If
I = I + 1
usBePath = .Cells(I, 1)
usBeName = .Cells(I, 2)
usAfPath = .Cells(I, 3)
usAfName = .Cells(I, 4)
Wend
End With

End Sub

で、ある程度は、可能だと思いますが置き換え後の「ファイル名が不正の場合」の検出をどうするか？考えてないので、その当りは注意してください
Ａ列から変更前のパス、Ｂ列から変更前のファイル名を読み取り
Ｃ列から変更後のパス、Ｄ列から変更後のファイル名を読み取り
Ｅ列に変換結果を出力しています

> .Cells(I,?)
の部分を差し替えてやれば、希望した列から読み取ります
> I=2
の部分で、１行目はタイトルが付いている前提で読み飛ばしてあります

で、モジュールってある程度わかります？

この回答へのお礼

ありがとうございます。
モジュールはほんの少ししか・・・・・
このマクロを実行するには、先にファイルの置いてある場所や保存する名称を記入しておくと言うことになるのでしょうか？

すみません、勉強不足で・・・・

お礼日時：2007/03/20 11:56

No.4 回答者： ham_kamo 回答日時： 2007/03/20 11:33

こんにちは。

これは
http://oshiete1.goo.ne.jp/kotaeru.php3?qid=2846439
の質問の続きですね。

やりたいことはだいたいわかったのですが、まだ不明な点があるので、確認させてください。

・上記URLの質問では、マクロが同じフォルダー内でないと動作しないため、たくさんのフォルダーに散らばっているテキストファイルとエクセルファイルをいちいち手で移動させているので、それをマクロでできないか、ということだったと思うのですが、この質問では「名称変更」のやり方を質問されていますね。同じドライブ内ならファイル名の変更もファイルの移動も同じ事なので、これは「名称変更して、マクロを動かすフォルダに移動」ということでよろしいでしょうか。

・この質問ではエクセルファイルについてしか書かれていませんが、前の質問ではテキストファイルもマクロを動かすフォルダに手で移動させて、と書いていました。これもマクロで自動的に移動させた方がよいのでしょうか。

・その場合、テキストファイルの場合はフォルダはたくさんあるけどファイル名は全部違うとありますが、テキストファイルが保存されているフォルダはどこにあるのでしょうか。質問文では

「あるフォルダ」＞「900個のフォルダ」＞「A,Bというフォルダ」＞エクセルファイル

という階層構造になっていますが、テキストファイルはこの中でどこにあたるのでしょうか。

・整理番号を元に型番と品番と結びつけるマクロを動かす（そのマクロの入っているブックがある）フォルダは、質問文冒頭の「あるフォルダー」なのでしょうか。それとも他にワーク用のフォルダがあるのでしょうか。

・上記マクロを動かした後、移動（名称変更）したエクセルファイル、テキストファイルは元のフォルダ、元のファイル名に戻すのでしょうか？

以上の点を補足願えますか？

この回答への補足

ありがとうございます。あちらもこちらもすみません。
１、マクロは同一フォルダー内でしか動作できません。
２、名称変更の理由としては、散らばっているファイルが同一名称のためです。
もし、名称変更ができれば、それぞれのファイル名（テキスト，エクセル）で関連性を持たせることで　それを元に処理する方が楽ではないかと思ったからです。
３、テキストもマクロを動かすフォルダに動かしています。
４、テキストも　あるフォルダ＞850個ほどのフォルダ＞フォルダ＞ファイル
５、テキストファイルと言っていますが、拡張子は付いていません。
６、動作させるマクロファイルは特に指定された場所にはありません。

７、エクセルのファイルも「Ａ，Ｂ」とフォルダ名称を書きましたが実際は異なる名称です　しかし２つあるのは確かです。

すみません、補足になりましたでしょうか？　
余計にわけがわからなくなってしまったかも知れませんね。

現在、テキストは同一名称ではないため　1つのフォルダーに入れてしまおうかと考えていますが・・・・・・

補足日時：2007/03/20 11:57

No.5 回答者： Dxak 回答日時： 2007/03/20 13:23

> このマクロを実行するには、先にファイルの置いてある場所や保存する

> 名称を記入しておくと言うことになるのでしょうか？

最初のファイル名が判らないと、どれをどれに変更するか判らないでしょ＾＾；

と、言う事で先に、ファイル名およびフォルダの変更前、変更後の一覧を作る必要があります
変更前に関しては下位のフォルダも検索して・・・等、考えると面倒なので・・・

フリーソフトで、ファイル名一覧で、ＣＳＶで作成可能なもので代用された方が、簡単だと思いますよ

No.6 回答者： ham_kamo 回答日時： 2007/03/20 13:46

No.4のham_kamoです。

とりあえず、書かれた仕様で、１つのフォルダにファイルを集めるマクロを組んでみました。エクセルファイルの場合はC4セルとH4セルを元に名称を変更し、その他のファイルの場合はそのまま移動します。

質問文で書いている「あるフォルダ」に新しいブックを作成し、Alt+F11でVBAの画面を開き、標準モジュールを追加して以下のマクロをコピーして貼り付けてください。

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 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
　Worksheets("Sheet1").Protect
　Application.StatusBar = ""
　Application.ScreenUpdating = False
　MsgBox ("完了しました")
End Sub

Sub ファイル名の変更と移動()
　Dim RootPath As String, WorkPath As String
　Dim R As Range
　RootPath = ThisWorkbook.Path & "\"
　WorkPath = "C:\temp\zzz\" 'ファイルを集めるフォルダを指定
　With Worksheets("Sheet1")
　　If .Range("A1") = "" Then Exit Sub
　　For Each R In .Range("C1", Cells(Rows.Count, "C").End(xlUp))
　　　Name RootPath & R.Value As WorkPath & R.Offset(0, 1).Value
　　Next
　End With
End Sub

Sub ファイル名を元に戻して元のフォルダに移動()
　Dim RootPath As String, WorkPath As String
　Dim R As Range
　RootPath = ThisWorkbook.Path & "\"
　WorkPath = "C:\temp\zzz\" 'ファイルを集めるフォルダを指定
　With Worksheets("Sheet1")
　　If .Range("A1") = "" Then Exit Sub
　　For Each R In .Range("C1", Cells(Rows.Count, "C").End(xlUp))
　　　Name WorkPath & R.Offset(0, 1).Value As RootPath & R.Value
　　Next
　End With
End Sub

上記２箇所に「'ファイルを集めるフォルダを指定」と注釈のついたところがあります。そこのフォルダ名は実際のフォルダ名に書き換えてください。

上記マクロは
「ファイル名一覧作成」
「ファイル名の変更と移動」
「ファイル名を元に戻して元のフォルダに移動」
の３つのプロシージャがあります。

「ファイル名一覧作成」を実行すると、サブフォルダのサブフォルダを探して、ファイル一覧をSheet1に作ります。A列にサブフォルダ一覧、B列にサブフォルダのサブフォルダ一覧、C列にB列の中で見つかったファイルの名称、D列に新しいファイル名を出力します。

それを実行した後、
「ファイル名の変更と移動」を実行すると、作成したファイル名一覧に基づき、ファイルをリネームしながら一箇所に移動します。

「整理番号を元に型番と品番と結びつけるマクロ」の処理が終わった後、「ファイル名を元に戻して元のフォルダに移動」を実行すると、集めたファイルを元のフォルダに戻し、ファイル名も元に戻します。ただし、Sheet1のファイル名一覧はこれを実行するまでに書き換えたりしないでください。（一応書き換えられないようにシート保護をかけています）

最初は900個もある本物のファイルで試すより、テスト用に一部のフォルダをコピーして動作確認をした方がよいでしょう。うまく動かない、あるいは何か不明な点があれば補足をお願いします。

この回答への補足

ありがとうございます返答が非常に遅くなり申し訳ありません。
テスト結果ですが
１、「ファイル名一覧作成」では　現状のマクロを置く位置をファイルが入っているフォルダの１つ上に置かないとだめなんですね。
現在頂いたファイルと同じ場所に4つのフォルダを置いてテストしています
そのうち、１つはフォルダ直下にエクセルファイルがあります　それは、リストには出ていません。
それ以外のものは、フォルダ下にフォルダがありその中にエクセルファイルがあるので表示されています。
あとシート１のセル幅がノーマルのためパスが分かりずらい感じです
２、「ファイル名の変更と移動」では実行時エラー５３　ファイルが見つからないとなり　
Name RootPath & R.Value As WorkPath & R.Offset(0, 1).Value
が反転されています。
WorkPath = "C:\Documents and Settings\*****\My Documents\test\z"
の位置にマクロファイルを置いていますが　だめです
すみません　

補足日時：2007/03/21 16:39

この回答へのお礼

'形状コードを探す
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
MsgBox "Z=" & r.Cells(n, 1) & "がNCファイルに見つかりません"
End If
n = n + 1
Loop

Else
MsgBox "NCファイルとZ表があっていません"
End If

End If

Else
MsgBox "NCファイルが見つかりません"
End If
End With


Workbooks("work.xls").Close SaveChanges:=False

あと少しあるのですが入れるものが無いのでこれぐらいです

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

No.7 回答者： ham_kamo 回答日時： 2007/03/21 18:40

こんにちは、ham_kamoです。

やはり一発ではうまくいかないものですね。１つ１つかたづけていきましょう。

●補足要求１
> １、「ファイル名一覧作成」では　現状のマクロを置く位置を
> ファイルが入っているフォルダの１つ上に置かないとだめなんですね。

とのことですが、私は「現状のマクロを置く位置」というのが、この質問文に出てくる「あるフォルダ」だと思っていたのですが、そうではなかったのでしょうか。

マクロでは「同じフォルダ内のファイルしか結びつけることができない」から「あるフォルダ」より下の階層にあるファイルをとりあえず全部「あるフォルダ」に持ってくる、そこでマクロも動かす、と思っていました。

マクロはどこのフォルダで動くのでしょうか。「あるフォルダ」の下に900個くらいのフォルダがある、とありますが、その900個のフォルダそれぞれでマクロを動かすのでしょうか？そうすると、ファイルを移動させる先も「あるフォルダ」でなく、その１段下のフォルダになるのでしょうか。

つまり、先の回答のマクロでは、

あるフォルダ\folder1\A\a.xls
を
WorkPathで指定したパス\aa1.xls　（aa1.xlsは変更された名前）
に移動

と処理するようになってますが、そうでなくて、

あるフォルダ\folder1\A\a.xls
を
あるフォルダ\folder1\aa1.xls
に移動

にする、ということでしょうか。

●補足要求２
> 現在頂いたファイルと同じ場所に4つのフォルダを置いてテストしています
> そのうち、１つはフォルダ直下にエクセルファイルがあります
> それは、リストには出ていません。

えっと、900個くらいフォルダがあって、その下にA,Bフォルダがあって、さらにその下にエクセルファイルがあると思っていたのですが、それだけでなくA,Bフォルダと同じ階層にもエクセルファイルがある、ということでしょうか。

上と同じ書き方をすると、

あるフォルダ\folder1\A\a.xls
あるフォルダ\folder1\B\a.xls
以外に、
あるフォルダ\folder1\a.xls

というパターンもあるということですか？

> あとシート１のセル幅がノーマルのためパスが分かりずらい感じです

すみません、シート保護をしたらセルの幅も変えられないのでした。これは自動的に幅を調整するように処理を追加します。

> ２、「ファイル名の変更と移動」では実行時エラー５３　ファイルが見つからないとなり

あ、これは、
WorkPath = "C:\Documents and Settings\*****\My Documents\test\z"

を

WorkPath = "C:\Documents and Settings\*****\My Documents\test\z\"

と最後に"\"を入れてください。

とりあえず、上記で挙げた、確認させていただきたい点の補足をいただいてからマクロを修正するので、とりあえず補足をお願いいたします。

この回答への補足

こんばんわ　度々申し訳ありません
１　testというフォルダを作りその下にｚと言うフォルダを作成しました。
そのzの中に対象となる5つのフォルダを入れた状態の場合
現在作成中のマクロを勝手ながらkhamとファイル名にさしていただいてますが
c:\temp\\z\ここに５つのフォルダABCDEとします
tempの階層にkhamを置いて走らせた場合は\Aの直下にエクセルがある場合は一覧表示に出てきますので　ｚの位置にkhamを置くと\B\a.xlsと表示されますが\Aは表示されません　たぶんイレギュラーだとは思うのですがたまたまテストに使用したフォルダーがそのようになっていました。
こんなのにも、対応可能なのでしょうか？
２、「ファイル名の変更と移動」ではパスをC:\temp\z\にしましたが
Name RootPath & R.Value As WorkPath & R.Offset(0, 1).Value
の所が黄色の反転で同一エラーで停止します

補足になりましたでしょうか？

補足日時：2007/03/21 20:29

この回答へのお礼

'エクセルファイルを開く
Workbooks.Open Filename:=ThisWorkbook.Path & "\work.xls"
Set s = Range("A1:A3000")
m = 1
k = 0
Do Until s.Cells(m, 1) = "" Or k <> 0
If Trim(s.Cells(m, 1)) = "MACHINE=MPAV" Then 'NCファイルからマシン名を探す
MACHINE = "MPAV"
k = 1
ElseIf Trim(s.Cells(m, 1)) = "MACHINE=MV2F" Then
MACHINE = "MV2F"
k = 1
ElseIf Trim(s.Cells(m, 1)) = "MACHINE=MV2C" Then
MACHINE = "MV2C"
k = 1
End If
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

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

No.8 回答者： ham_kamo 回答日時： 2007/03/21 22:19

なるほど、だいたいわかりました。

とりあえず、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)

補足日時：2007/03/22 00:08

この回答へのお礼

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

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

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

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

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

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

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

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

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