may the VBA be with you

Excel VBAとか業務自動化とか

VBAでこんなことできます_その1 フォルダ作成

イントロ

どうもinageです。
最近はRPAとかを中心に業務自動化であれこれやっております。

RPAとかGASとかIFTTTとか、手作業でやっていたことを自動化できる仕組みが色々あって、便利な世の中ですね。

たまに理解のある現場だと「VBAで良くないっすか」という意見が通ったり、運が良いと「じゃあちょっと教えてよ」と言われることもあって嬉しい限りです。

そんな時、「VBAでこんなことできます」ととりあえず見せて「おー」と言ってもらいたい。

何も準備がない時にすぐに見せられるものがあればいいな、ということで久しぶりにこのブログを思い出しました。

あんまり見せられるものがない。。。

簡単なもので、どんなことができるかわかるようなものをほぼ自分のためにいくつか上げていきたいとおもいます。

どんなマクロ

フォルダを選択して、その配下にサブフォルダを一括で作ります。

f:id:vba-belle-equipe:20190710114928p:plain
フォルダ作成マクロ

使い方

1)フォルダ選択ボタン-> フォルダを選択する
2)B7以下に作りたいサブフォルダ名を入力していく
3)フォルダ作成ボタンを押す

コード

Option Explicit

Sub フォルダ選択()
    Dim r As Range
    Set r = Sheets(1).Range("B2")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path
        If .Show = True Then
            r = .SelectedItems(1)
        End If
    End With
End Sub

Sub フォルダ作成()
    Dim rootPath As String
    Dim i As Long
    Dim maxRow As Long
    Dim folderName As String
    Dim fullPath As String
    Const startRow = 7
    
    rootPath = Range("B2")
    If Dir(rootPath, vbDirectory) = "" Then
        MsgBox "フォルダを選択してください"
        End
    End If
    
    maxRow = Cells(Rows.Count, 2).End(xlUp).Row
    If maxRow < startRow Then
        MsgBox "サブフォルダ名をB列に1つ以上入れてください"
        End
    End If
    
    For i = startRow To maxRow
        folderName = Cells(i, 2)
        fullPath = rootPath & "¥" & folderName
    '    Debug.Print i & "_" & fullPath
        If Dir(fullPath, vbDirectory) = "" Then
            MkDir fullPath
        End If
    Next
    
End Sub

ファイルのダウンロード

フォルダ作成01.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

諸注意

Windowsで動作します
・デモ用なので、エラー処理とかちゃんとやってません
・自由に使っていただいて構いませんが、自己責任でお願いします
・バナナはおやつに入りません