may the VBA be with you

Excel VBAとか業務自動化とか

フォルダ作成マクロ ができるまで その3

はじめに

前回、

vba-belle-equipe.hatenablog.com

画面上からマクロを実行できるようになりました。

今回はもうひと工夫してみましょう。

作成先フォルダを選択する

現状では、

f:id:vba-belle-equipe:20160314202703p:plain

A1セルにフォルダのパスがあり、その場所にサブフォルダを作るようにしています。

作成先のフォルダを変えたい場合は、A1セルの値を変えればいいわけです。

・・・どうやって?

手段が2つも用意されていますが、調子に乗ってもう1つ選択肢を増やしましょう。

VBAでフォルダ選択させてみる

vba フォルダ選択」で検索するといつもお世話になるこのページ。

Office TANAKA - Excel VBA Tips[フォルダを選択するダイアログ]

いくつか手段があることがわかります。

記述が簡単なやり方

Sub test()
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      Debug.Print .SelectedItems(1)
    End If
  End With
End Sub

これはよく使います。

何しろ記述が簡単なので。

f:id:vba-belle-equipe:20160316152834p:plain

見た目はこんな感じ。

見た目がそれっぽいやり方

Sub test2()
  Dim Shell As Object
  Dim myPath As Object
  Set Shell = CreateObject("Shell.Application")
  Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
  If Not myPath Is Nothing Then
    Debug.Print myPath.Items.Item.Path
  End If
  Set Shell = Nothing
  Set myPath = Nothing
End Sub

ちょっとごちゃごちゃしています。

f:id:vba-belle-equipe:20160316153948p:plain

見た目がそれっぽいです。*1

A1セルにセットする

今回は記述が簡単なほうでいってみます。

Sub setRootPath()
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      Range("A1") = .SelectedItems(1)
    End If
  End With
End Sub

こんな感じです。

ダブルクリックで実行させる

前回、A列をダブルクリックでフォルダ作成できるようにしました。

1行目をダブルクリックした場合はフォルダを選択できるようにしてみましょう。

シートモジュールのダブルクリックイベントを

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Column <> 1 Then
    Exit Sub
  End If
  Cancel = True
  Select Case Target.Row
    Case 1
      Call setRootPath
    Case Else
      Call makeFolders
  End Select
End Sub

上のように変更すればOKです。

おまけ

A1セルをVBAで選択できるようにしましたが、コピペや手入力できる余地は残しておきたい。

そこで、

  • フォルダ作成前に、そのパスにフォルダが存在するかどうかをチェック
  • パスの最後に「¥」がついていてもいなくても大丈夫に

するようにしましょう。

Sub makeFolders()
  Dim i As Long
  Dim maxRow As Long
  Dim rootPath As String, fldPath As String
  rootPath = Range("A1")
  If Right(rootPath, 1) = "¥" Then
    rootPath = Left(rootPath, Len(rootPath) - 1)
  End If
  If Dir(rootPath, vbDirectory) = "" Then
    MsgBox "作成先フォルダが存在しません"
    Exit Sub
  End If
  maxRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 3 To maxRow
    fldPath = rootPath & "¥" & Cells(i, 1)
    If Dir(fldPath, vbDirectory) = "" Then
      MkDir fldPath
    End If
  Next
End Sub

まとめ

ちょっとシステムっぽくなってきました。

その分、記述も長くなってきてウンザリいい感じですが、もう少しだけ続きます。

*1:個人の感想です