Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6717 / 13644 ツリー ←次へ | 前へ→

【43185】フォルダを自動で並び替えて整理したい カド 06/10/5(木) 8:43 質問[未読]
【43193】Re:フォルダを自動で並び替えて整理したい ハチ 06/10/5(木) 14:00 発言[未読]
【43259】Re:フォルダを自動で並び替えて整理したい カド 06/10/7(土) 8:58 お礼[未読]
【43288】Re:フォルダを自動で並び替えて整理したい ハチ 06/10/8(日) 8:01 発言[未読]
【43357】Re:フォルダを自動で並び替えて整理したい ハチ 06/10/11(水) 12:48 発言[未読]
【43558】Re:フォルダを自動で並び替えて整理したい カド 06/10/19(木) 11:06 お礼[未読]

【43185】フォルダを自動で並び替えて整理したい
質問  カド  - 06/10/5(木) 8:43 -

引用なし
パスワード
   自動で毎日データを落としていて、
以下のように、各カテゴリーに日々のデータが
日付のフォルダに入っています。

そして山のように、10月02日のデータがない時は
フォルダもありません。

また、花、山、海といったカテゴリーも、その時々で
増えて行きます。


花 ¥06年10月01日
  ¥06年10月02日
  ¥06年10月03日

山 ¥06年10月01日
  ¥06年10月03日
  
海 ¥06年10月01日
  ¥06年10月02日
  ¥06年10月03日
  




このような状況において、フォルダ以下のように整理し直したいのですが、
お分かりの方回答のほどよろしくお願いします。


06年10月01日¥花
         ¥山
         ¥海

06年10月02日¥花
         ¥海

06年10月03日¥花
         ¥山
         ¥海

【43193】Re:フォルダを自動で並び替えて整理したい
発言  ハチ  - 06/10/5(木) 14:00 -

引用なし
パスワード
   ▼カド さん:

>花 ¥06年10月01日
このときに"花"直下にもファイルがあるのでしょうか?

Scripting.FileSystemObjectの
Folders,SubFolders あたりを使えばできそうです。
調べてみてはいかがですか?

【43259】Re:フォルダを自動で並び替えて整理したい
お礼  カド  - 06/10/7(土) 8:58 -

引用なし
パスワード
   ▼ハチ さん 回答ありがとうございます。
>
>>花 ¥06年10月01日
>このときに"花"直下にもファイルがあるのでしょうか?

花の直下にはファイルはありません。

****************************************

いつもこんなこと無理だろって思っていることでも、意外とシンプルな
コードであっさりと解決される方がみえるので、一応質問してみましたが、
やはりこんなことはそう簡単には出来ないですよね。

自分で地道に考えてみて、その中の部分的に分からないことがあれば、
またお尋ねしようと思います。

【43288】Re:フォルダを自動で並び替えて整理したい
発言  ハチ  - 06/10/8(日) 8:01 -

引用なし
パスワード
   ▼カド さん:
>▼ハチ さん 回答ありがとうございます。
>>
>>>花 ¥06年10月01日
>>このときに"花"直下にもファイルがあるのでしょうか?
>
>花の直下にはファイルはありません。
>
>****************************************
>
>いつもこんなこと無理だろって思っていることでも、意外とシンプルな
>コードであっさりと解決される方がみえるので、一応質問してみましたが、
>やはりこんなことはそう簡単には出来ないですよね。
>
>自分で地道に考えてみて、その中の部分的に分からないことがあれば、
>またお尋ねしようと思います。

再構成したいフォルダが、2階層だけならそんなに難しくないです。(たぶん)

↓の例SubFolderをScripting.FileSystemObjectのFolderObjectとして
ループをまわすことができます。

  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set 親フォルダ = FSO.GetFolder(パス)
  For Each 子フォルダ In 親フォルダ.SubFolders
    子フォルダ.Name
  Next 子フォルダ

孫フォルダまであるなら、In 子フォルダ.SubFoldersとループを重ねれば良いと思います。
あとは、.Name .Path で作りたいPath名を生成して(子と孫を入れ替えれば良い)
If Dir(新しいパス) = "" Then MkDir(新しいパス)
と新しいフォルダ構成を作っていく。

FolderObjectとして掴んでますので
For Each ファイル In 子フォルダ.Files
 ファイル.Copy 新しいパス & ファイル.Name
Next
とするとファイルをコピーしていけると思います。

こんな感じを想定していたのですがどうでしょうか?
(時間がなくて半端なレスになってスイマセン・・・)

もっと簡単な方法もあるかも・・・

【43357】Re:フォルダを自動で並び替えて整理したい
発言  ハチ  - 06/10/11(水) 12:48 -

引用なし
パスワード
   ▼カド さん:
>>自分で地道に考えてみて、その中の部分的に分からないことがあれば、
>>またお尋ねしようと思います。

もう諦めちゃいましたか?

いちお、自分の想定してたコードで出来るのは確認できました。
参考までに。

Option Explicit

Sub FSO_Test()
  Dim FSO As Object    'Scripting.FileSystemObject
  Dim Ro_Fol As Object  '親フォルダ
  Dim Ko_Fol As Object  '子フォルダ
  Dim Mago_Fol As Object '孫フォルダ
  Dim myFile As Object  'フォルダ内のファイル
  Dim NewPath As String  '新しいパス
  Dim KoPath As String  'フォルダ作成用のパス
  Dim Des_Ro As String  '再構成先のルートパス
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set Ro_Fol = FSO.GetFolder(ThisWorkbook.Path)
  
  Des_Ro = ThisWorkbook.Path & "\並び替え後"
  Chk_MkDir (Des_Ro)
  
  For Each Ko_Fol In Ro_Fol.SubFolders
    If Ko_Fol.Path <> Des_Ro Then
      For Each Mago_Fol In Ko_Fol.SubFolders
        'フォルダ生成
        KoPath = Des_Ro & "\" & Mago_Fol.Name
        Chk_MkDir (KoPath)
        NewPath = KoPath & "\" & Ko_Fol.Name
        Chk_MkDir (NewPath)
        'ファイルコピー
        For Each myFile In Mago_Fol.Files
          myFile.Copy NewPath & "\" & myFile.Name
        Next myFile
      Next Mago_Fol
      'Ko_Fol.Delete  '削除は十分テストしてから
    End If
  Next Ko_Fol
  
  Set Ro_Fol = Nothing
  Set FSO = Nothing
End Sub

Sub Chk_MkDir(StrPath)
  If Dir(StrPath, vbDirectory) = "" Then MkDir (StrPath)
End Sub

【43558】Re:フォルダを自動で並び替えて整理したい
お礼  カド  - 06/10/19(木) 11:06 -

引用なし
パスワード
   ▼ハチ さん回答ありがとうございます。

諦めた訳ではないのですが、手元にリネーム用コードが有ったので、
これをちょっといじれば実現できることに気づきまして、
中途半端にいつでもやれる状態だったので、中だるみと言うか
一時中断状態でした。

回答いただいたコードで、ばっちり目的どうり動きました。
手元に有るコードを改良したものより、はるかにシンプルで
大変すばらしいです。

ありがとうございました。

6717 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free