フォルダ作成

Option Explicit
Option Base 1
Public Const WS_DATA As String = "データ"
Public Const NEW_FOLDER As String = "新規"

Sub CreateFolder()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim fso As Object
    Dim wbPath As String
    Dim newFolderPath As String
    Dim fileName  As String
    Dim beforeCount As Integer
    Dim afterCount As Integer
    Dim res As Boolean
    Dim fArray() As Variant
    Dim i As Integer, n As Integer
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(WS_DATA)
    
    With ws
      'A列データの有無を確認
      If .Range("A1") = "" Then
        MsgBox "A列にデータを貼り付けてください"
        Exit Sub
      End If
      
      '現在のA列の入力数を確認し、重複データを削除
      beforeCount = .Columns("A:A").Cells(Rows.count, 1).End(xlUp).Row
      .Range("A1:A" & beforeCount).RemoveDuplicates Columns:=1, Header:=xlNo
       DoEvents
       
      '重複データを削除後のデータ数取得
      afterCount = .Columns("A:A").Cells(Rows.count, 1).End(xlUp).Row
      
      'データを配列格納
      fArray = .Range("A1:A" & afterCount)
    End With
    
    'このブックのパス
    wbPath = wb.Path & "\"
    
    '作成するフォルダを格納するフォルダ名
    '「新規」+タイムスタンプ
    fileName = NEW_FOLDER & Format(Now, "yyyymmdd_hhmmss")
    
    '格納するフォルダがすでに存在するか否か
    newFolderPath = wbPath & fileName
    res = fso.FolderExists(newFolderPath)
    
    'すでに格納するフォルダ名が存在する場合は、処理中止
    If res Then
        MsgBox "格納するのフォルダが存在します。" & vbNewLine & "処理を中止します。"
        Exit Sub
    End If
    
    '格納するフォルダ作成
    fso.CreateFolder (newFolderPath)
    n = 0
    
    '作成したフォルダ内にサブフォルダを作成(A列データ)
    For i = 1 To UBound(fArray)
        If fArray(i, 1) <> "" Then
            fso.CreateFolder (newFolderPath & "\" & fArray(i, 1))
            n = n + 1
        End If
    Next i
    
    Set ws = Nothing
    Set wb = Nothing
    Set fso = Nothing
    
    MsgBox n & "個のフォルダを作成しました"
End Sub

Sub dataClear()
    Columns("A:A").ClearContents
    Range("A1").Select
End Sub