[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダを作成する方法』（まりも）
あるサイトで見つけたマクロを使いたいんですがエラーがでて上手くいきません
教えてください
フォルダを階層別に作成するマクロです
フォルダパス：B10〜K10までセル結合
階層：見出しは12行目、B13から
エラー：fs.CreateFolder s
実行時エラー76 パスが見つかりません
Sub 作成_Click()
Dim i As Long, cmax As Long, x As Long, z As Long, cnt As Long, j As Long, k As Long
Dim ws1 As Worksheet
Dim str As String, url As String
Dim s As String, s1 As String
Dim n1 As Long
Dim fs As FileSystemObject
Set fs = New Scripting.FileSystemObject
Set ws1 = Worksheets("フォルダ作成")
cmax = ws1.Cells(Rows.Count, 1).End(xlUp).Row
cnt = ws1.Cells(12, Columns.Count).End(xlToLeft).Column
'[1] セルB10にURLが記載されているかチェック
If ws1.Range("B10").Value = "" Then
MsgBox "セルB10に「作成先のフォルダURL」を入力して下さい"
ws1.Range("B10").Activate
Exit Sub
End If
url = ws1.Range("B10").Value
'[2] 同じ行に複数回記入されていないことを確認
For i = 13 To cmax
x = 0
For j = 0 To cnt - 2
If ws1.Cells(i, 2).Offset(0, j).Value <> "" Then
x = x + 1
End If
Next
If x > 1 Then
z = z + 1
End If
Next
'[3] 同じ行に複数回記入されていた場合、処理を止める
If z > 0 Then
MsgBox "入力情報を見直してください"
Exit Sub
End If
'[4] 階層別にフォルダを作成する
For j = 0 To cnt - 2
For i = 13 To cmax
If ws1.Cells(i, 2).Offset(0, j).Value <> "" Then
s1 = ws1.Cells(i, 2).Offset(0, j).Value
For k = 0 To j
If k - j = 0 Then
Exit For
End If
n1 = ws1.Cells(i, 2).Offset(0, j - k - 1).End(xlUp).Row
s1 = ws1.Cells(n1, 2).Offset(0, j - k - 1).Value & "\" & s1
Next
s = url & "\" & s1
fs.CreateFolder s
End If
Next
Next
Set fs = Nothing
End Sub
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
単純に s のパスが存在してないんじゃないですか？ その行の手前に debug.print s stop と記述して、イミディエイトウィンドウに想定した値が表示されているか確認してください。 http://officetanaka.net/excel/vba/error/execution_error/error_76.htm （稲葉） 2020/08/27(木) 13:51
作りたいフォルダが5個（AA、BB、CC、DD、EE）だとすると
イミディエイトウィンドウは
\\hp-server\あああ\いいい\ううう\えええ\おおお
\\hp-server\あああ\いいい\ううう\えええ\おおお￥AA
\\hp-server\あああ\いいい\ううう\えええ\おおお￥BB
\\hp-server\あああ\いいい\ううう\えええ\おおお￥CC
でエラーとなります
フォルダはAAとBBだけできました
沢山のフォルダを作らないといけないので使えるようになると嬉しいです
（まりも） 2020/08/27(木) 14:43
横から失礼します。
パスに使えない文字が含まれてないか確認してみてください。 あと、パスの文字数制限に引っ掛かってないかもご確認ください。 （OK） 2020/08/27(木) 14:51
フォルダ一覧で取得したフォルダ名を別のフォルダに作成しているので
使えない文字や文字数制限ではないのかなと思います
＞全角の\なんですか？
半角のまちがいです
すいません
\\hp-server\あああ\いいい\ううう\えええ\おおお
\\hp-server\あああ\いいい\ううう\えええ\おおお\AA
\\hp-server\あああ\いいい\ううう\えええ\おおお\BB
\\hp-server\あああ\いいい\ううう\えええ\おおお\CC
（まりも） 2020/08/27(木) 15:48
＞使えない文字や文字数制限ではないのかなと思います 思いますじゃなくて確認してくれませんか？ 正確なデータを提示してくれないんじゃこっちではどうにもならない
http://tanaka-misaki.blogspot.com/2012/02/excel-vba.html
ファイル名に使えない文字をチェックするコードが転がってるから、簡単にできるでしょう？
（稲葉） 2020/08/27(木) 16:36
このコードってB列以外見てないと思うけど余分なところ多くない？
＞If x > 1 Then これだと、B列以外全部不要だし
＞ For j = 0 To cnt - 2 ＞ For k = 0 To j ＞ If k - j = 0 Then ＞ Exit For こっちもjもkも0からスタートだから、必ずexit forですよね？
（稲葉） 2020/08/27(木) 17:57
元ネタ見つけた そのまま使ってみはどうですか？
（稲葉） 2020/08/27(木) 18:06
新しく作ったので、こちらで試してもらえますか？
Sub フォルダ作成()
Dim ws As Worksheet
Dim fp As String '----最初のフォルダ名
Dim w As Variant '---階層フォルダ名を格納する配列
Dim buf As String '----行ごとの階層フォルダ名をつなげる
Dim isMake As Boolean '---フォルダを作成したかどうか
Dim msg As String '----作成したフォルダのパスを保管する
Dim r As Long '------配列の行方向のループ
Dim c As Long '------配列の列方向のループ
Dim re As Object '----正規表現
Set re = CreateObject("VBScript.REGExp")
With re
.Pattern = "[\\/:*?""<>|\[\]]"
.Global = True
End With
Set ws = Sheets("フォルダ作成")
fp = ws.Range("B10").Value '------------------------------------------最初のフォルダ名の指定
If fp <> "" Then
fp = fp & IIf(Right(fp, 1) = "\", "", "\")
w = ws.Range("F13", ws.Cells(Rows.Count, "B").End(xlUp)).Value '--階層を増やしたいときは、F列をZ列方向に増やす
For r = 1 To UBound(w, 1)
buf = ""
isMake = False
For c = 1 To UBound(w, 2)
If w(r, c) <> "" Then
If Not re.test(w(r, c)) Then '------------------------不正なフォルダ名チェック
buf = buf & "\" & w(r, c)
If Dir(fp & Mid(buf, 2), vbDirectory) = "" Then 'フォルダの有無チェック
MkDir fp & Mid(buf, 2) '----------------------フォルダの作成
isMake = True
End If
Else
msg = msg & vbCrLf & "不正なフォルダ名：" & w(r, c) & vbCrLf
isMake = False
Exit For
End If
Else
Exit For '--------------------------------------------列（階層）が空白だったら、次の行に抜ける
End If
Next c
If isMake Then msg = msg & vbCrLf & Mid(buf, 2)
Next r
If msg <> "" Then
MsgBox "以下のフォルダを作成ｏｒ失敗しました" & vbCrLf & msg
Else
MsgBox "フォルダは作成されませんでした。"
End If
Else
MsgBox "B10にフォルダのパスを指定してください"
End If
Set re = Nothing
' |[A] |[B] |[C] |[D] |[E] |[F]
' [10]| |C:\test| | | |
' [11]| | | | | |
' [12]| |1階層目|2階層目|3階層目|4階層目|5階層目
' [13]|1件目 |AB |100番〜| | |
' [14]|2件目 |AB |200番〜| | |
' [15]|3件目 |err/ | | | |
' [16]|4件目 |CD |EF |GH | |
' [17]|5件目 | | | | |
' [18]|6件目 | | | | |
' [19]|7件目 | | | | |
' [20]|8件目 | | | | |
' [21]|9件目 | | | | |
' [22]|10件目| | | | |
End Sub
（稲葉） 2020/08/27(木) 18:57
____A_____________B_________________ 1 \\hp-server\あああ\いいい\ううう\えええ\おおお 2 3 AA ="md "&$A$1&"\"&A3 4 BB ↓必要なだけ（フィル）コピー 5 CC 6 DD 7 EE 8 9
コードで悩むより↑のような感じで、整理しておいてから、
(1)B3〜をコピーする (2)メモ帳に貼り付ける (3)"テキトー.bat"という名前でデスクトップに保存する (4)デスクトップに作成された"テキトー.bat"をダブルクリックする
ということをやった方がよくないでしょうか？
（パスに日本語が含まれる場合、場合によっては文字コードでトラブルかもですが・・）
（もこな２ ） 2020/08/27(木) 19:02
エラーの中身調べたら、やっぱり階層を飛ばして作ろうとしてないですかね？
s = "b\a" の時、パスがありませんのエラーだったので、CCというフォルダあたりに、\マークを含んだ文字列が含まれていると思いますよ。
Sub aaa()
Dim a As Object
Dim s As String
Dim msg As String
With CreateObject("Scripting.FilesyStemObject")
On Error Resume Next
.Delete "C:\a"
s = "a": .CreateFolder "C:\" & s
msg = s & ":" & Err.Description & vbCrLf
s = "a": .CreateFolder "C:\" & s
msg = s & ":" & Err.Description & vbCrLf
s = "<>": .CreateFolder "C:\" & s
msg = msg & s & ":" & Err.Description & vbCrLf
s = "b\a": .CreateFolder "C:\" & s
msg = msg & s & ":" & Err.Description & vbCrLf
On Error GoTo 0
End With
MsgBox msg
End Sub
（稲葉） 2020/08/27(木) 19:28
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Long) As Long
Sub test()
Call SHCreateDirectoryEx(0&, "\\hp-server\あああ\いいい\ううう\えええ\おおお\AA", 0&)
End Sub
エラーを拾いたい場合はCallではなく、変数で受けてください。 既にあるか、作成失敗かを判定できます。
（???） 2020/08/28(金) 10:22
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.