Ｅｘｃｅｌブックの振り分け

あるコードがファイル名となっているブックが５００個（！）ほど１つのディレクトリに入っています。そのコードを基にマスタを参照して、それぞれのフォルダへ移動させたいと思います。（社員番号のファイル名でそれを基に部署フォルダに振り分けるようなイメージ）。VBAを使えばいいのでしょうが、何をどうしたものやら・・。緊急なんですが、お願いします！

No.3 ベストアンサー 回答者： nishi6 回答日時： 2002/02/08 18:31

500個ほどのファイルを、そのファイルを基準に振り分ける例です。

マスタ(book)の
　社員番号(ファイル名)に該当するセル範囲に『社員コード』、
　部署に該当する範囲に『部署コード』の範囲名を付けます。
VBA内の2つのフォルダを設定します。
ただし、2つのフォルダが異なるドライブにあると使えません。

マスタ(book)の『社員コード』、『部署コード』が入っているシートのコードウインドウに貼り付けます。
実行する時は、元ファイルのコピー（バックアップ）を行った後、実行して下さい。


Sub Furiwake()
　　Const srcFolder = "A:\社員\" '*** Bookのあるフォルダ(指定する)
　　Const desFolder = "A:\部署\" '*** 振り分けるフォルダ(指定する)

　　Dim fileName As String 'Excelファイル名
　　Dim rg As Range '検索した社員コードのセル
　　Dim schCode As String '検索する社員コード
　　Dim schFolder As String '検索した社員コードに対するフォルダ

　　fileName = Dir(srcFolder & "*.xls")
　　While fileName <> ""
　　　　'ファイル名からコードを取り出す
　　　　schCode = Application.Substitute(fileName, ".xls", "")
　　　　'取り出したコードと一致するセルを探す
　　　　Set rg = Range("社員コード").Find(what:=schCode, LookAt:=xlWhole)
　　　　If Not rg Is Nothing Then
　　　　　　'取り出したコードと一致するセルと同じ行の部署を取り出す
　　　　　　schFolder = Cells(rg.Row, Range("部署コード").Column)
　　　　　　'フォルダ＋ファイル名でファイル名前を変える
　　　　　　Name srcFolder & fileName As desFolder & schFolder & "\" & fileName
　　　　Else
　　　　　　'コードが見つからなかった時
　　　　　　MsgBox fileName & "の対象部署はありません"
　　　　End If

　　　　'次のExcelファイル
　　　　fileName = Dir
　　Wend
End Sub

No.2 回答者： TTak 回答日時： 2002/02/08 17:59

こんな感じでしょうか・・・

あとは実際の条件に合わせて文字列関数の所を変化させる、
CASEの項目を増やすなどしてください。
当方はEXCEL2000で動作確認しました。

Sub FileMoveme()
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("500個ファイルがあるフォルダのパス")
Set fc = f.Files
For Each f1 In fc
Select Case Left(f1.Name, 1)'先頭の1文字で区別する場合
Case "A"
f1.Move "振り分けるフォルダAのパス" & f1.Name
Case "B"
f1.Move "振り分けるフォルダBのパス" & f1.Name
Case "C"
f1.Move "振り分けるフォルダCのパス" & f1.Name
Case Else
End Select
Next
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
End Sub

No.1 回答者： gonta_goma 回答日時： 2002/02/08 15:30

マスタがどんな形なのか分からないのですが、例えばExcelのワークシートのA列にコードが、B列に部署名が、1行から500行まで並んでいる様なもので、ファイル名が123.xlsのとき、コードは123だとします。

そしてC:\ABCのフォルダにファイルが500個存在し、C:\DEFのフォルダに部署名のフォルダが、例えば C:\DEF\営業部 の様な形で存在しているとします。
マスタのワークシートで、以下のマクロを実行すればどうでしょうか。
Sub Macro1()
　Dim i As Long
　On Error Resume Next
　ChDir "C:\ABC"
　For i = 1 To 500
　　Name "C:\ABC\" & Cells(i, 1) & ".xls" As "C:\DEF\" & Cells(i, 2) & "\" & Cells(i, 1) & ".xls"
　Next i
End Sub