階層の多数あるフォルダの統合

質問

同様の質問を先般致しましたが、
わかりにくかったかもしれませんでしたので
あらためて質問させてくださいませ
CドライブのフォルダAには
フォルダ　1,1(2),1(3),,1(5)のように
フォルダがあり、その下層には
さらにサブフォルダが以下のようにあります。
すべてのフォルダ名は数字で表現されてますが、
数字の桁数が５桁以下のフォルダであれば、各フォルダには
サブフォルダはさらには存在せず、jpgファイルが数個あります。
数字の桁数が6桁以上のフォルダであれば、添付ファイルで
示されたように更にサブフォルダが存在します。
ここで５桁以下の数字で表されているフォルダだけ、
まとめて統合したフォルダUにコピペしたいというのが主旨です。
しかしながら、同名の５桁フォルダがあり、上書きはしないで、フォルダ内の
jpgファイル名を4000jpg,4000(1)jpgのように別ファイル名として残したいのです。
この場合のVBAまたはジェイソンファイルなどでのコードを
御教示いただきたく存じます
宜しくお願い致します

win10

C:.
│
│
├─1
│ ├─2
│ │ ├─13561
│ │ │ 4843.jpg
│ │ │ 4844.jpg
│ │ │ 4845.jpg
│ │ │
│ │ ├─36158
│ │ │ 4846.jpg
│ │ │ 4847.jpg
│ │ │ 4848.jpg
│ │ │
│ │ ├─40068
│ │ │ 4840.jpg
│ │ │ 4841.jpg
│ │ │ 4842.jpg
│ │ │
│ │ └─40069
│ │ 4837.jpg
│ │ 4838.jpg
│ │ 4839.jpg
│ │
│ ├─2 (2)
│ │ ├─10647
│ │ │ 4578.jpg
│ │ │ 4579.jpg
│ │ │ 4580.jpg
│ │ │ 4581.jpg
│ │ │
│ │ ├─11814
│ │ │ 4552.jpg
│ │ │ 4553.jpg
│ │ │ 4554.jpg
│ │ │ 4555.jpg
│ │ │
│ │ ├─13412
│ │ │ 4560.jpg
│ │ │ 4561.jpg
│ │ │ 4562.jpg
│ │ │
│ │ ├─18001
│ │ │ 4556.jpg
│ │ │ 4557.jpg
│ │ │ 4558.jpg
│ │ │ 4559.jpg
│ │ │
│ │ ├─3541
│ │ │ 4566.jpg
│ │ │ 4567.jpg
│ │ │ 4568.jpg
│ │ │ 4569.jpg
│ │ │ 4570.jpg
│ │ │ 4571.jpg
│ │ │
│ │ ├─35488
│ │ │ 4605.jpg
│ │ │ 4606.jpg
│ │ │ 4607.jpg
│ │ │ 4608.jpg
│ │ │ 4609.jpg
│ │ │ 4610.jpg
│ │ │
│ │ ├─35554
│ │ │ 4582.jpg
│ │ │ 4583.jpg
│ │ │ 4584.jpg
│ │ │ 4585.jpg
│ │ │ 4586.jpg
│ │ │
│ │ ├─36666
│ │ │ 4512.jpg
│ │ │ 4513.jpg
│ │ │ 4514.jpg
│ │ │ 4515.jpg
│ │ │ 4516.jpg
│ │ │ 4517.jpg
│ │ │ 4518.jpg
│ │ │
│ │ ├─37119
│ │ │ 4596.jpg
│ │ │ 4597.jpg
│ │ │ 4598.jpg
│ │ │
│ │ ├─37310
│ │ │ 4611.jpg
│ │ │ 4612.jpg
│ │ │ 4613.jpg
│ │ │ 4614.jpg
│ │ │ 4615.jpg
│ │ │
│ │ ├─39443
│ │ │ 4616.jpg
│ │ │ 4617.jpg
│ │ │ 4618.jpg
│ │ │ 4619.jpg
│ │ │
│ │ ├─39716
│ │ │ 4522.jpg
│ │ │ 4523.jpg
│ │ │ 4524.jpg
│ │ │ 4525.jpg
│ │ │
│ │ ├─40013
│ │ │ 4531.jpg
│ │ │ 4532.jpg
│ │ │ 4533.jpg
│ │ │ 4534.jpg
│ │ │ 4535.jpg
│ │ │ 4536.jpg
│ │ │ 4537.jpg
│ │ │ 4538.jpg
│ │ │
│ │ ├─40035
│ │ │ 4519.jpg
│ │ │ 4520.jpg
│ │ │ 4521.jpg
│ │ │
│ │ ├─40036
│ │ │ 4539.jpg
│ │ │ 4540.jpg
│ │ │ 4541.jpg
│ │ │
│ │ ├─40037
│ │ │ 4549.jpg
│ │ │ 4550.jpg
│ │ │ 4551.jpg
│ │ │
│ │ ├─40038
│ │ │ 4572.jpg
│ │ │ 4573.jpg
│ │ │ 4574.jpg
│ │ │
│ │ ├─40039
│ │ │ 4563.jpg
│ │ │ 4564.jpg
│ │ │ 4565.jpg
│ │ │
│ │ ├─40040
│ │ │ 4602.jpg
│ │ │ 4603.jpg
│ │ │ 4604.jpg
│ │ │
----------------
----------------
│ │
│ ├─40026
│ │ 4406.jpg
│ │ 4407.jpg
│ │ 4408.jpg
│ │ 4409.jpg
│ │ 4410.jpg
│ │
│ ├─40027
│ │ 4401.jpg
│ │ 4402.jpg
│ │ 4403.jpg
│ │
│ └─9361
│ 4423.jpg
│ 4424.jpg
│ 4425.jpg
│ 4426.jpg
│ 4427.jpg
│
└─20201031
├─13653
│ 4473.jpg
│ 4474.jpg
│ 4475.jpg
│ 4476.jpg
│ 4477.jpg
│
├─17823
│ 4478.jpg
│ 4479.jpg
│ 4480.jpg
│ 4481.jpg
│
├─21209
│ 4499.jpg
│ 4500.jpg・・・

回答No.5

kkkkkm · ベストアンサー

それでいいのでしょうかな感じがするので

> 数字の桁数が５桁以下のフォルダであれば、各フォルダには
> サブフォルダはさらには存在せず、jpgファイルが数個あります。

1の所から探し始めるとした場合
2と2(2)は上記の条件での5桁以下となりますのでサブフォルダは検索対象外となりファイルは何もなしという結果になります。
─13561
が2のサブフォルダを示しているとしてです。

20201031
は「桁数が6桁以上のフォルダ」に該当しますからその下のサブフォルダは検索対象になりサブフォルダとファイルのコピーはされます。

2から始めた場合は下の階層しか見ません(上も見るとなるとC:まで行ってしまいます)から2(2)と20201031は検索対象外となります。

> 4000jpg,4000(1)jpgのように別ファイル名として残したい

3個目4個目があった場合は4000jpg,4000(1)jpg,4000(2)jpg,4000(3)jpgとするのでしょうか。

同じ環境を作るのが面倒なので申し訳ありませんが私はコードの回答はしません。
回答する方の参考になるかもと思って上記の個人的な疑問を出してみます。

実行前、実行後のデータを参考にあげたらわかりやすいのではないでしょうか。

お礼

2と2(2)は上記の条件での5桁以下となりますのでサブフォルダは検索対象外となりファイルは何もなしという結果＞＞仰る通りでした　凡ミスしてました　再チャレンジします

Powered by GRATICA

回答No.4

gennya

お礼ありがとうございました。
これまでの質問内容やお礼内容をみる限り、あまりプログラミングが分かっていないのではと思いました。
（わざとそういうフリをしているのかもしれませんが）

私は丸投げでコードを書いてもらおうとすることは否定的ではありません。なぜなら、得意な方が短時間で回答してくれる場面を何度も見たことがあるからです。（そういう方は苦と思っていない）

しかしながら、得意な方でも貴殿の環境は分からないので、回答いただいたコードを環境に合わせて書き換える必要がありますが、それさえも出来ないのではと推測します。
ということは何度質問しても、期待する回答は得られないのではと思います。

回答No.3

gennya

質問内容は以下であっていますか？
フォルダA以下の全フォルダを調べる
5桁以下の数字のフォルダの全ファイルをコピー
コピーしたファイルをファルダUにペースト
同じファイル名があった場合、ファイル名をカッコ付き連番とする

質問事項は、以下のどれなのでしょうね？
個人的に便利なプログラムを作りたい
会社で業務に使いたい
学校での宿題
など

お礼

仰せの通りです。業務より個人的に便利なプログラムを作りたい＞＞に該当します　当方、診療所を経営するものでして、患者さんのカルテ番号が、フォルダ５桁の番号でjpgはカルテです。camscannerに、ばらば保存していたものを統合したいです。

Powered by GRATICA

補足

御礼に書きましたことの修正です
camscannerというストレージサービスに保存すると、ダウンロードしたときに日付フォルダなどで多層階層のフォルダになってダウンロードされてしまいます　そこで　ばらばらのIDフォルダをひとつのフォルダに統合したい、という主旨で御座います。
https://okwave.jp/qa/q10254036.html
こちらでも御回答を多数　頂きましたが
残念ながら　うなく稼働しませんでした
ちなみにchatGPTで以下のコードが出来ましたが、やはりうまくいきません
どこに問題があるでしょうか？---すみません
Sub フォルダを統合する()
Dim 元のフォルダ As String
Dim 統合先フォルダ As String
Dim FSO As Object
Dim 元のフォルダ内のフォルダ As Object
Dim 元のフォルダ内のファイル As Object
Dim 対象フォルダ As Object
Dim 新しいフォルダ名 As String
Dim 新しいファイル名 As String
Dim i As Integer

' 元のフォルダと統合先フォルダのパスを指定します
元のフォルダ = "C:\A" ' ご自身のフォルダパスに置き換えてください
統合先フォルダ = "C:\U" ' ご自身のフォルダパスに置き換えてください

' FileSystemObjectを作成します
Set FSO = CreateObject("Scripting.FileSystemObject")

' 統合先フォルダが存在しない場合は、作成します
If Not FSO.FolderExists(統合先フォルダ) Then
FSO.CreateFolder (統合先フォルダ)
End If

' 元のフォルダ内のすべてのフォルダを探索します
Set 元のフォルダ内のフォルダ = FSO.GetFolder(元のフォルダ).SubFolders
For Each 対象フォルダ In 元のフォルダ内のフォルダ
' フォルダ名が5桁以下の場合のみ処理します
If Len(対象フォルダ.Name) <= 5 Then
' 同名のフォルダが存在する場合は、新しい名前でフォルダを作成します
If FSO.FolderExists(統合先フォルダ & "\" & 対象フォルダ.Name) Then
i = 1
Do While FSO.FolderExists(統合先フォルダ & "\" & 対象フォルダ.Name & " (" & i & ")")
i = i + 1
Loop
新しいフォルダ名 = 対象フォルダ.Name & " (" & i & ")"
Else
新しいフォルダ名 = 対象フォルダ.Name
End If

' 新しいフォルダを作成します
FSO.CreateFolder (統合先フォルダ & "\" & 新しいフォルダ名)

' フォルダ内のファイルをコピーします
For Each 元のフォルダ内のファイル In 対象フォルダ.Files
新しいファイル名 = Replace(元のフォルダ内のファイル.Name, 対象フォルダ.Name, 新しいフォルダ名)
元のフォルダ内のファイル.Copy 統合先フォルダ & "\" & 新しいフォルダ名 & "\" & 新しいファイル名
Next 元のフォルダ内のファイル
End If
Next 対象フォルダ

' メッセージを表示します
MsgBox "フォルダの統合が完了しました。", vbInformation
End Sub

回答No.2

type0（@type0）

chtGPTで、生成し、編集すべき箇所があるのにも、関わらず、それが出来ていないという事は、丸投げですね。さっき、言った事と、ほぼ変わってないですよ。

お礼

こちらの方面は素人ですので、さらに内容を絞っての質問はキャパシティを超えたものとなってしまうのです。もしもお知恵をお持ちでしたら、御借り願えませんでしょうか？不可能でしたら、沈黙での御対応を、宜しくお願い致します。

Powered by GRATICA

回答No.1

type0（@type0）

これって
「質問」
風ですが、要は、
「質問内容に書いてる要求仕様を満たすプログラムコードを納品せよ」
という事ですよね。

プログラム書いて、テストして～ってなると、それなりに時間はかかりますので、親切な方が居れば別ですが、対価無しで、それは難しいと思いますよ。

質問であれば、ある程度、プログラムを書いて、
「ここが上手く動かないので、教えてほしい」
になりますかね。

要求仕様を満たすプログラムを希望であれば、ココナラやクラウドワークスなどのビジネスマッチングサイトに依頼すべきです。

補足

chatGPTで以下のコードが出来ましたが、うまくいきません
どこに問題があるでしょうか？---
Sub フォルダを統合する()
Dim 元のフォルダ As String
Dim 統合先フォルダ As String
Dim FSO As Object
Dim 元のフォルダ内のフォルダ As Object
Dim 元のフォルダ内のファイル As Object
Dim 対象フォルダ As Object
Dim 新しいフォルダ名 As String
Dim 新しいファイル名 As String
Dim i As Integer

' 元のフォルダと統合先フォルダのパスを指定します
元のフォルダ = "C:\A" ' ご自身のフォルダパスに置き換えてください
統合先フォルダ = "C:\U" ' ご自身のフォルダパスに置き換えてください

' FileSystemObjectを作成します
Set FSO = CreateObject("Scripting.FileSystemObject")

' 統合先フォルダが存在しない場合は、作成します
If Not FSO.FolderExists(統合先フォルダ) Then
FSO.CreateFolder (統合先フォルダ)
End If

' 元のフォルダ内のすべてのフォルダを探索します
Set 元のフォルダ内のフォルダ = FSO.GetFolder(元のフォルダ).SubFolders
For Each 対象フォルダ In 元のフォルダ内のフォルダ
' フォルダ名が5桁以下の場合のみ処理します
If Len(対象フォルダ.Name) <= 5 Then
' 同名のフォルダが存在する場合は、新しい名前でフォルダを作成します
If FSO.FolderExists(統合先フォルダ & "\" & 対象フォルダ.Name) Then
i = 1
Do While FSO.FolderExists(統合先フォルダ & "\" & 対象フォルダ.Name & " (" & i & ")")
i = i + 1
Loop
新しいフォルダ名 = 対象フォルダ.Name & " (" & i & ")"
Else
新しいフォルダ名 = 対象フォルダ.Name
End If

' 新しいフォルダを作成します
FSO.CreateFolder (統合先フォルダ & "\" & 新しいフォルダ名)

' フォルダ内のファイルをコピーします
For Each 元のフォルダ内のファイル In 対象フォルダ.Files
新しいファイル名 = Replace(元のフォルダ内のファイル.Name, 対象フォルダ.Name, 新しいフォルダ名)
元のフォルダ内のファイル.Copy 統合先フォルダ & "\" & 新しいフォルダ名 & "\" & 新しいファイル名
Next 元のフォルダ内のファイル
End If
Next 対象フォルダ

' メッセージを表示します
MsgBox "フォルダの統合が完了しました。", vbInformation
End Sub