VBAでリスト通りにフォルダを作成

質問

excelのvbaでアクティブブックが入っているフォルダの中に"sheet1"のA列のリスト通りに名前を付けフォルダを作成したいです。リストに重複した名前がない場合はできますが、図のように重複した名前が入っているとどうすればいいか分からなく、ここに質問します。
どなたか知恵を貸していただけませんか？
どうぞよろしくお願いいたします。

回答No.2

SI299792 · ベストアンサー

on error gotoを使ってエラーを無視すればいいです。
'
Sub Macro1()
'
　　For iy = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　On Error Resume Next
　　　　MkDir Cells(iy, "A")
　　　　On Error GoTo 0
　　Next iy
End Sub

on error gotoが嫌なら、以下の方法があります。
dir で、vbDirectoryを指定すれば、フォルダの有無がわかります。
'
Sub Macro2()
'
　　Dim FileName As String
'
　　For iy = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　FileName = Cells(iy, "A")
　　　　Debug.Print Dir(FileName)
'
　　　　If Dir(FileName, vbDirectory) = "" Then
　　　　　　MkDir FileName
　　　　End If
　　Next iy
End Sub

お礼

ご回答ありがとうございました。
望んでいたぴったりのご回答でした。
お二人ともありがとうございました。

回答No.1

imogasi

同じ名前のブックは１つのフォルダーでは作れないのだから、こんなことを言っても仕方がないのではないか。たとえば
シートの自動的命名例があるように、（１）、（２）、・・のようなものを、１，２，３・・などのあとに、ひつっけて作るのがどうか。
（）内の数字はＷｏｒｋＳｈeｅｔＦｕｎｃｔｉｏｎ.ＣＯＵＮＴＩＦ関数を使えば簡単。
Ｓｈｅｅｔ名の例でテスト。
下記で”Ｓｈｅｅｔ”　の部分は、他の文字列にすることはできる。
Sub test01()
Set sh1 = Worksheets("シート名リスト")
For i = 1 To 7
c = Application.WorksheetFunction.CountIf(sh1.Range("A1:A" & i), sh1.Cells(i, "A"))
If c = 1 Then
a = ""
Else
a = "(" & c & ")"
End If
MsgBox a
'--
Worksheets.Add
n = "Sheet" & sh1.Cells(i, "A") & a
sh1.Cells(i, "B") = n
MsgBox n
ActiveSheet.Name = n
Next i
End Sub
「シート名リスト」シートではＡ列は元データ、Ｂ列で作ってはという案
Ａ列　　Ｂ列
1 　Sheet1
1 　Sheet1(2)
2 　Sheet2
2 　Sheet2(2)
5 　Sheet5
5 　Sheet5(2)
5 　Sheet5(3)
となり、上記は確認用だが、シート名はＢ列の名でＡＤＤされている。
ブックの例に修正するのは簡単だろう。

補足

さっそくのご回答ありがとうございました。
同じ名前のフォルダは名前の後ろに（番号）を付けて作成することはよくわかりました。
ただし、リストにある重複フォルダ名の数だけ作りたいのではなく、1個だけ作る場合はどうすればよろしいでしょうか？
説明が足りなかったので申し訳ございませんでした。
よろしくお願いいたします。