連番フォルダ自動作成
目次
メインモジュール・コード
Option Explicit
Sub メイン()
formメニュー.Show
End Sub
Sub フォルダ作成(ByVal rngList As Range, Optional ByVal tgtFolder As String = "")
If tgtFolder = "\" Then Exit Sub 'フォルダ選択がされていない場合(¥のみ)は何もしないで終了
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim myRng As Variant
Dim tgtFullName As String
On Error Resume Next
For Each myRng In rngList
If myRng.Value <> "" Then
tgtFullName = tgtFolder & myRng.Value
FSO.CreateFolder (tgtFullName)
End If
Next myRng
Set FSO = Nothing
'エラー表示
Call エラー表示("フォルダ作成完了")
End Sub
Sub フォルダ削除(ByVal rngList As Range, Optional ByVal tgtFolder As String = "")
If tgtFolder = "\" Then Exit Sub 'フォルダ選択がされていない場合(¥のみ)は何もしないで終了
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim myRng As Variant
On Error Resume Next
For Each myRng In rngList
If myRng.Value <> "" Then
FSO.DeleteFolder (tgtFolder & myRng.Value)
End If
Next myRng
Set FSO = Nothing
'エラー表示
Call エラー表示("フォルダ削除完了")
End Sub
Function フォルダ選択()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show = True Then
フォルダ選択 = .SelectedItems(1)
Else
MsgBox "選択されていません"
フォルダ選択 = ""
End If
End With
End Function
Sub エラー表示(Optional ByVal myMsg As String)
If Err.Number <> 0 Then
MsgBox "エラー番号:" & Err.Number & vbCrLf & _
"エラーの種類:" & Err.Description, vbExclamation
Else
MsgBox myMsg
End If
End Sub
ユーザフォーム・コード
Option Explicit
Private Sub btn終了_Click()
Unload formメニュー
End Sub
Private Sub btn実行_Click()
Dim rngList As Range
Set rngList = Range(Range("C2"), Range("C2").End(xlDown))
Select Case cmbメニュー.Text
Case "フォルダ作成"
Call フォルダ作成(rngList, フォルダ選択() & "\")
Case "フォルダ削除"
Call フォルダ削除(rngList, フォルダ選択() & "\")
Case Else
MsgBox "機能が選択されていません。"
Exit Sub
End Select
End Sub
Private Sub UserForm_Initialize()
With cmbメニュー
.AddItem "フォルダ作成"
.AddItem "フォルダ削除"
End With
End Sub
解説
【説明】
C列の名称で空のフォルダを作成(または削除)する。
リストに追記することで追加することも可能(ただし空白を含まないようにする)。
ツールダウンロード