gooドクター有料プランが1ヶ月間無料!

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

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

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


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

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

宜しくお願い致します。

gooドクター

A 回答 (3件)

内容を換えました。


このマクロの特徴は、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
    • good
    • 0

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


個別要素のコードは、良くある例なので、WEB照会で直ぐ見つけられます。
前問の回答にも使えるものがあります。前問の回答の周辺事項が身についてないのでは。回答コピーで動けば良しとするからでしょう。
(1)在るフォルダのすべてのフォルダを採り上げるコード
(2)新規にフォルダを作成し、望みのフォルダ名にするコード
(3)振り分けの判別(ファイル名の文字列の一部を切り出し、IF分を使うだけ)
(4)ファイルをコピーして指定のフォルダに入れるコード
などGoogleででも照会すれば、沢山ありますよ。
照会のキーワードは
(1)VB Dir
(2)VB Mkdir
(3)Mid関数
(4)VB copy
http://homepage1.nifty.com/rucio/main/Samples/s_ …
日本語で、例えば(2)は「VB フォルダ作成」などで照会しても良い
ーー
本質問については、それぞれFSO(FileSystemObject)のコードでやる方法もあります。
(4)はMoveFileもある。
    • good
    • 0
この回答へのお礼

書いて頂いた項目、順次調べさせてもらっています。
ご丁寧にありがとうございました。

お礼日時:2010/10/17 00:52

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


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

それぞれがうまく出来るか確認の上。次のステップに進んでください。
ステップ1
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列で指定したファイル名コピィします。
簡単なコードですので、ご自身で理解して使ってください。
お酒も履いてしまっているので スペルミスなどもあるかもしれません。
検証もしていていませんの保証もいたしません。
ご自身の責任で実行してください。
    • good
    • 0
この回答へのお礼

そういう懸念があったのですね。。
確かに出力すると数千ファイルが生成されるので、
間違った場合の削除にも手間がかかりました。。

教えて頂いたこと、慎重に検証させていただきますね^^
ありがとうございます。

お礼日時:2010/10/17 00:56

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

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

gooドクター

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

人気Q&Aランキング