（VBA) 同名フォルダーの存在をチェック

質問

以下のコード（Sub ⑤フォルダー名の変更()）でフォルダー名の変更を行っています。

変名時に同名ファイルがある場合エラーが以下のコードでエラーがでます。
　　.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text

エラー無く処理したいので
　同名があるばあいは、フォルダー名の末尾に（1）、(2)を付加したいのですが
　同名があるかどうかは？どのように判定しますか　？

Sub ⑤フォルダー名の変更()

Dim i As Long
Dim LastColumn As Single
Dim LastColumn_ABC As String
Dim MSG As String

LastColumn = Cells(5, "B").End(xlToRight).Column
LastColumn_ABC = Split(Cells(1, LastColumn).Address, "$")(1)

MSG = MsgBox("B列フォルダー名が" & LastColumn_ABC & "列フォルダー名に変更されます！" & vbCrLf _
& "B," & LastColumn_ABC & "列に値がなければ、処理は行いません。", 257, "フォルダー名変更")

If MSG = vbCancel Then Exit Sub

i = 5 'subフォルダ名取得が5行目からフォルダー名を表示するため。

Do While Range("b" & i).Text <> ""

If Cells(i, LastColumn).Text <> "" Then ' 新フォルダー名がある場合のみ、名前変更を行う。
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text
End With
End If

i = i + 1

Loop

MsgBox "変名処理が終了しました。"
End Sub

回答No.3

kkkkkm · ベストアンサー

> さすがに同じフォルダー名で（）の中の数字も同じフォルダー名が
> 　すでに存在することは無いような気がします。

無ければそれでいいと思います。ただ、「（1）、(2)を付加したい」と質問にあったので、ある事を想定してるのかなと思いました。

> イミディエイトウィンドウへの出力結果で
> 　　　￥１と表示されていますが1個の重複があるとの意味でしょうか　？

「新フォルダー名がある場合のみ、名前変更を行う」のところだけの変更コードでしたのでテスト時に
LastColumn = 3
i = 2
と適当な値で設定してますのでC2に何もなければそうなると思います。本来はフォルダー名1になります。
実際のデータの適切な指定に変更してください。

> 　又、重複していないフォルダーの変名処理が行われていないように思います。

Else
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text

の部分で行われると思いますが…C2に何もなければ行われないと思います。

また、重複フォルダーでの操作でイミディエイトにて正しいパスが生成できるようでしたら、変名処理を行っていただければと思っています。

一例として
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Replace(newfolderName, Range("A2").Value, "")
という方法でもいけると思います。

> 一部コードを以下のように修正しました。
> .GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text & "(" & (i - 4) & ")"

準じて以下の部分を変更してください。

Function Fcheck(ByRef fso As Object, ByVal folderPath As String, ByRef fNo As Long) As String
With fso
If .FolderExists(folderPath & "(" & fNo & ")") Then
fNo = fNo + 1
Call Fcheck(fso, folderPath, fNo)
End If
End With
Fcheck = folderPath & "(" & fNo & ")"
End Function

補足

うっかりミスが多くてお世話をおかけしています。

>LastColumn = 3
>i = 2
>と適当な値で設定してますのでC2に何もなければそうなると思います。

コードの下の方ばかりを見ていたので
　LastColumnとiの設定が実際と違っているのに気が付きませんでした。

実際にマッチした設定で試してみます。

旨く行かなかったら又書き込みしますので少し時間をください。
（うまく処理できたら、解決としたいです。）

回答No.2

kkkkkm

> If CreateObject("Scripting.FileSystemObject").FolderExists(range)"A2") & cells(i,LastColumn)) Then
> With CreateObject("Scripting.FileSystemObject")
> .GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text & (i-4)

多分これだとCells(i, LastColumn).Text & (i-4)と同じフォルダが既にあった場合エラーになるような気がします。

変更しようとするフォルダがある場合、再帰呼び出しで再度チェックするようにしたらいかがでしょう。
Debug.Print NewfolderName
で新しいフォルダ名をイミディエイトに出していますので確認してください。

Sub Test()
Dim fso As Object
Dim folderPath As String, newfolderName As String
Dim i As Long, LastColumn As Long, fNo As Long

LastColumn = 3
i = 2

Set fso = CreateObject("Scripting.FileSystemObject")
fNo = 1
With fso
If .FolderExists(Range("A2") & Cells(i, LastColumn)) Then
newfolderName = Fcheck(fso, Range("A2") & Cells(i, LastColumn).Text, fNo)
Debug.Print newfolderName
Else
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text
End If
End With

End Sub

Function Fcheck(ByRef fso As Object, ByVal folderPath As String, ByRef fNo As Long) As String
With fso
If .FolderExists(folderPath & fNo) Then
fNo = fNo + 1
Call Fcheck(fso, folderPath, fNo)
End If
End With
Fcheck = folderPath & fNo
End Function

お礼

コードの訂正ありがとうございます。

>多分これだとCells(i, LastColumn).Text & (i-4)と同じフォルダが既にあった場合エラーになるような気がします。

さすがに同じフォルダー名で（）の中の数字も同じフォルダー名が
　すでに存在することは無いような気がします。

一部コードを以下のように修正しました。
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text & "(" & (i - 4) & ")"

「再帰呼び出し」と言うマクロ素人には思い付かない方法で
　転ばぬ先の杖的エラー回避を教えていただいたので
　コードをそのまま利用させていただき確認してみました。

　イミディエイトウィンドウへの出力結果で
　　　￥１と表示されていますが1個の重複があるとの意味でしょうか　？

　又、重複していないフォルダーの変名処理が行われていないように思います。
　（test()実施前後のフォルダーの名前に変化がありません。）

----------------------------
私のコード（Sub ⑤フォルダー名の変更_改()）を行うと
　元フォルダーが変名後に添付画像のようになり
　一応うまく処理できているように思えます。

添付画像（参考画像）
　https://imgur.com/Zscju6b

回答No.1

kkkkkm

VBAでフォルダ存在チェック
https://vbabeginner.net/folder-existence-check/
こちらを参照してください。

お礼

urlの紹介ありがとうございます。

紹介いただいたURLと違うのですが下記のURLが参考になりそうです。

https://tonari-it.com/excel-vba-exists-folder-create/

つまり、ラフなコードとして以下のように考えましたが
　修正箇所の指摘をお願いします。

Sub ⑤フォルダー名の変更()

Dim i As Long
Dim LastColumn As Single
Dim LastColumn_ABC As String
Dim MSG As String

LastColumn = Cells(5, "B").End(xlToRight).Column
LastColumn_ABC = Split(Cells(1, LastColumn).Address, "$")(1)

MSG = MsgBox("B列フォルダー名が" & LastColumn_ABC & "列フォルダー名に変更されます！" & vbCrLf _
& "B," & LastColumn_ABC & "列に値がなければ、処理は行いません。", 257, "フォルダー名変更")

If MSG = vbCancel Then Exit Sub

i = 5 'subフォルダ名取得が5行目からフォルダー名を表示するため。

Do While Range("b" & i).Text <> ""

If Cells(i, LastColumn).Text <> "" Then ' 新フォルダー名がある場合のみ、名前変更を行う。
If CreateObject("Scripting.FileSystemObject").FolderExists(range)"A2") & cells(i,LastColumn)) Then
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text & (i-4)
end with
else
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text
end wit
elnd if
End If

i = i + 1

Loop

MsgBox "変名処理が終了しました。"
End Sub

Sub フォルダの存在確認をしてなければ作成する()

Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")

Dim strFolderPath As String

MsgBox "フォルダpdfは存在しています"
Else
strFolderPath = objFso.CreateFolder(ThisWorkbook.Path & "\pdf")
MsgBox "フォルダpdfは存在しなかったので作成しました" & vbNewLine & strFolderPath
End If

Set objFso = Nothing

End Sub

補足

すいません。
　最初に書いたコードの修正版です。

Sub ⑤フォルダー名の変更_改()

Dim i As Long
Dim LastColumn As Single
Dim LastColumn_ABC As String
Dim MSG As String

LastColumn = Cells(5, "B").End(xlToRight).Column
LastColumn_ABC = Split(Cells(1, LastColumn).Address, "$")(1)

MSG = MsgBox("B列フォルダー名が" & LastColumn_ABC & "列フォルダー名に変更されます！" & vbCrLf _
& "B," & LastColumn_ABC & "列に値がなければ、処理は行いません。", 257, "フォルダー名変更")

If MSG = vbCancel Then Exit Sub

i = 5 'subフォルダ名取得が5行目からフォルダー名を表示するため。

Do While Range("b" & i).Text <> ""

If Cells(i, LastColumn).Text <> "" Then ' 新フォルダー名がある場合のみ、名前変更を行う。
If CreateObject("Scripting.FileSystemObject").FolderExists(Range("A2") & Cells(i, LastColumn)) Then
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text & (i - 4)
End With
Else
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text
End With
End If
End If

i = i + 1

Loop

MsgBox "変名処理が終了しました。"
End Sub