多量のファイルをフォルダに自動振り分けするマクロを教えて下さい。

Question

エクセルVBAで、一行の内容を1つのテキストファイルに出力して、
連続処理で複数行を一気に複数ファイルに生成しています。

そのマクロは以前質問して教えて頂いたマクロで、下記のアドレスから
ご覧くださいませ。
http://oshiete.goo.ne.jp/qa/6201310.html
ファイル生成のマクロは、回答No.２の方が教えてくれたマクロを採用し
ています。(ベストアンサー)

生成するファイル名は4桁の数字なんですが、ファイル自動生成時に、
ファイル名が1000番代のファイルは、フォルダ名が1のフォルダに収め、
2000番代は2のフォルダへ・・といった具合に9000番代まで収めたいのです。

ファイルは生成できているので、 あとはフォルダの自動生成と
自動振り分けができるマクロを教えて頂けませんか？

宜しくお願い致します。

Wendy02 · Accepted Answer

内容を換えました。
このマクロの特徴は、2列目を使うファイル名は4桁の数--つまり数字であるということ。
フォルダが見つからないと、マクロはストップしてしまいます。

'//
Sub TestMacro1()
　Dim i As Long, k As Variant, j As Long, m
　Dim fn As String
　Dim mPath As String, nPath As String
　Dim rng As Range, ar As Variant
　Dim buf As String
　Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(, 2))
　'パスを決める（CurDir は、カレントディレクトリ）
　mPath = CurDir & "\"　'末尾には必ず￥を入れます。
　ar = rng.Value
　For i = 1 To rng.Rows.Count
　　fn = Format(ar(i, 2), "0000") & ".txt"
　　nPath = mPath & Left$(fn, 1) & "\"
　　If Dir(nPath, vbDirectory) = "" Then MsgBox "Folderが見つかりません", 48: Exit Sub
　　Do Until Dir(nPath & fn) = ""
　　　k = Val(k) + 1
　　　j = InStr(1, fn, "(", 1)
　　　If j > 0 Then
　　　'同名ファイルの場合
　　　　fn = Mid(fn, 1, j - 1) & "(" & k & ")" & ".txt"
　　　Else
　　　　fn = Replace(fn, ".txt", "", , , 1) & "(" & k & ")" & ".txt"
　　　End If
　　Loop
　　Open nPath & "\" & fn For Output As #1
　　Print #1, ar(i, 1) & ar(i, 2) & ar(i, 3)
　　Close #1
　　k = ""
　　nPath = ""
　Next
　If Len(buf) > 2 Then
　　MsgBox Mid(buf, 2) & vbCrLf & "重複のため保存は省かれました。"
　Else
　　MsgBox mPath & "に出力されました。"
　End If
End Sub

imogasi · Answer

勉強（と言ってもＷＥＢ照会してコードをさがす程度）をせず、全面的に回答頼りになっていませんか。
個別要素のコードは、良くある例なので、WEB照会で直ぐ見つけられます。
前問の回答にも使えるものがあります。前問の回答の周辺事項が身についてないのでは。回答コピーで動けば良しとするからでしょう。
（１）在るフォルダのすべてのフォルダを採り上げるコード
（２）新規にフォルダを作成し、望みのフォルダ名にするコード
（３）振り分けの判別（ファイル名の文字列の一部を切り出し、ＩＦ分を使うだけ）
（４）ファイルをコピーして指定のフォルダに入れるコード
などＧｏｏｇｌｅででも照会すれば、沢山ありますよ。
照会のキーワードは
（１）VB Dir
（２）VB　Mkdir
（３）Mid関数
（４）VB copy
http://homepage1.nifty.com/rucio/main/Samples/s_sh3.htm
日本語で、例えば（２）は「VB　フォルダ作成」などで照会しても良い
ーー
本質問については、それぞれFSO（FileSystemObject）のコードでやる方法もあります。
（４）はMoveFileもある。

hallo-2007 · Answer

>ファイルは生成できているので、 あとはフォルダの自動生成と
>自動振り分けができるマクロを教えて頂けませんか？
この手の質問に回答するのはかなり度胸が必要なのですよ。
間違ったコードや操作でパソコンの中をめちゃくちゃにしてしまう可能性もあるからです。
参考程度の回答を致します。
失敗の事を考えて２つのステップで操作します。
ステップ１
指定したフォルダ内のファイル名をエクセルのシートに一覧で表示させます。
ステップ2
表示されたファイル名を別のフォルダーにコピィする。
ステップ3
うまく出来たらフォルダ内のファイルを削除する。

それぞれがうまく出来るか確認の上。次のステップに進んでください。
ステップ１
B2セルに　ファイルが入っているフォルダ名を入れておきます。
Sub ボタン1_Click()
Dim Buf As String
Range("C3:D1000").ClearContents
Buf = Dir(Range("B2").Value & "\" & "*.*")
i = 3
Do While Buf <> ""
 Range("C" & i).Value = Buf
 Range("D" & i).Value = Left(Range("C" & i).Value,1)
 Buf = Dir()
 i = i + 1
Loop
End Sub

DirについてはWeb調べると色々と説明がされています。

C3セル以下にファイル名の一覧
D3セル以下にはファイル名の最初の1文字がでます。

Sub ボタン2_Click()
For i=3 To Range("C65536").End(Xlup).Row 
FileCopy Range("B2").Value & "\" & Rnage("C" & i).Value, Range("D" & i).Value & "\" & Range("C" & i).Value
Next
End Sub

FileCopy　コピィ元のパスとファイル名,コピィ先のパスとファイル名　と指定して使います。

B2セルで指定したフォルダ（パス）で
C列のファイル名を　D列で指定したフォルダへ　C列で指定したファイル名コピィします。
簡単なコードですので、ご自身で理解して使ってください。
お酒も履いてしまっているので　スペルミスなどもあるかもしれません。
検証もしていていませんの保証もいたしません。
ご自身の責任で実行してください。

多量のファイルをフォルダに自動振り分けするマクロを教えて下さい。

内容を換えました。

勉強（と言ってもＷＥＢ照会してコードをさがす程度）をせず、全面的に回答頼りになっていませんか。

>ファイルは生成できているので、 あとはフォルダの自動生成と

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

>ファイルは生成できているので、あとはフォルダの自動生成と