回答編集履歴

2

同一フォルダ名が存在する場合のエラー回避処理追加

2018/10/22 10:17

投稿

TanakaHiroaki
TanakaHiroaki

スコア1063

test CHANGED
@@ -50,7 +50,9 @@
50
50
 
51
51
   フォルダ名が固定でないことを踏まえ、For Each 構文の多重ループを使用してみました。
52
52
 
53
+  その後、移動先に同一フォルダ名が存在する場合のエラー回避処理を追加しました。
54
+
53
-  動作確認をしていませんが、参考にしてください。
55
+ 動作確認をしていませんが、参考にしてください。
54
56
 
55
57
  ```VBA
56
58
 
@@ -74,7 +76,15 @@
74
76
 
75
77
  For Each fol3 In fol2.SubFolders
76
78
 
79
+ If FSO.FolderExists(ThisWorkbook.Path & "\画像\" & fol3.Name) Then
80
+
81
+ MsgBox "同一フォルダ名がありますので処理をスキップします。"
82
+
83
+ Else
84
+
77
- Call FSO.MoveFolder(fol3.Path, ThisWorkbook.Path & "\画像\")
85
+ FSO.MoveFolder CStr(fol3), ThisWorkbook.Path & "\画像\"
86
+
87
+ End If
78
88
 
79
89
  Next fol3
80
90
 

1

For Each 構文の多重ループを用いたコード追記

2018/10/22 10:17

投稿

TanakaHiroaki
TanakaHiroaki

スコア1063

test CHANGED
@@ -45,3 +45,47 @@
45
45
  Set FSO = Nothing
46
46
 
47
47
  ```
48
+
49
+ <追記>
50
+
51
+  フォルダ名が固定でないことを踏まえ、For Each 構文の多重ループを使用してみました。
52
+
53
+  動作確認をしていませんが、参考にしてください。
54
+
55
+ ```VBA
56
+
57
+ '「画像」フォルダに移動
58
+
59
+ Dim FSO As FileSystemObject
60
+
61
+ Set FSO = New FileSystemObject
62
+
63
+
64
+
65
+ Dim fol1 As Folder, fol2 As Folder, fol3 As Folder
66
+
67
+
68
+
69
+ For Each fol1 In FSO.GetFolder(ThisWorkbook.Path).SubFolders
70
+
71
+ If fol1.Name <> "画像" Then
72
+
73
+ For Each fol2 In fol1.SubFolders
74
+
75
+ For Each fol3 In fol2.SubFolders
76
+
77
+ Call FSO.MoveFolder(fol3.Path, ThisWorkbook.Path & "\画像\")
78
+
79
+ Next fol3
80
+
81
+ Next fol2
82
+
83
+ End If
84
+
85
+ Next fol1
86
+
87
+
88
+
89
+ Set FSO = Nothing
90
+
91
+ ```