「今さら」なんてない

「自分にもできそう」を伝播させるブログ

テーブルからフォルダを一括作成する【Excel VBA】

ファイル管理めんどい...

Excelでデータベース作っておいて
該当する案件の写真とか付帯資料を入れておくフォルダを紐づけられないか
というお声があったのでささっと作りました

ざっくり機能の説明

  1. 指定テーブルの指定列の内容を拾って
    テーブルのデータ数分フォルダを一括作成する
    複数列の情報をまとめられる
    (例では通し番号&登録コード名
  2. 作成したフォルダのハイパーリンクを付与

標準モジュールにコピペするコード

Option Explicit

Const No桁数 = 3

Enum c  '列No.
  No = 1
  登録コード名
End Enum

Sub フォルダ一括作成()
  Application.ScreenUpdating = False
  
  Dim ws1 As Worksheet: Set ws1 = Sheets("Main")
  Dim ws2 As Worksheet: Set ws2 = Sheets("Setting")
  Const 収集するテーブル名 = "テーブル1"
  Dim 作成先 As String: 作成先 = ws2.Cells(1, 1).Value

  Dim フォルダ名 As String
  Dim No桁数補正後 As String
  
  Dim Arr As Variant
  Set Arr = ws1.ListObjects(収集するテーブル名).DataBodyRange
  
  Dim タイトル行 As Long, テーブル最終行 As Long
  タイトル行 = Arr(1, 1).Row - 1
  テーブル最終行 = Arr(Arr.Count).Row
  
  Dim i As Long
  For i = 1 To テーブル最終行 - タイトル行
    No桁数補正後 = 指定桁数になるように頭に0を付与(Arr(i, c.No).Value, No桁数)
    フォルダ名 = No桁数補正後 & "_" & Arr(i, c.登録コード名)
    Call ハイパーリンクの付与(Cells(i + タイトル行, c.登録コード名), フォルダ作成(作成先, フォルダ名))
  Next
  
  MsgBox テーブル最終行 - タイトル行 & "個のフォルダを作成しました" & vbCrLf & _
    "【登録コード名】列にフォルダリンクを作成しました"
  Application.ScreenUpdating = True

End Sub

Function フォルダ作成(作成先 As String, フォルダ名 As String) As String
  On Error Resume Next  'ほんまはアカンけどすでにフォルダがある場合のエラーを無視する
  MkDir 作成先 & "\" & フォルダ名
  フォルダ作成 = 作成先 & "\" & フォルダ名
End Function

Sub ハイパーリンクの付与(対象セル As Range, リンク As String)
  ActiveSheet.Hyperlinks.Add Anchor:=対象セル, Address:=リンク
End Sub

Function 指定桁数になるように頭に0を付与(n As Long, 指定桁数 As Long)
  指定桁数になるように頭に0を付与 = Right(n + 10 ^ 指定桁数, 指定桁数)
End Function

各自アレンジするところ

テーブルの列番号

Enum c  '列No.
  No = 1
  登録コード名
End Enum

例では
1列目にNo
2列目に登録コード名
としていますが

Enum(列挙変数型)で列番号を指定し直せばどうとでも変更可能です

シート名

  Dim ws1 As Worksheet: Set ws1 = Sheets("Main")
  Dim ws2 As Worksheet: Set ws2 = Sheets("Setting")

参照するテーブルを入れてあるのがws1
フォルダ作成先を入れてあるのがws2
としています

適当にシート名を変えるかコードを変えるかしてください

テーブル名

  Const 収集するテーブル名 = "テーブル1"

テキトーに"テーブル1"としていますが
好きに変えてください

通し番号の桁数

Const No桁数 = 3

1→001といった感じでそろえる桁数を設定します

いったん3桁にしていますが
必要に応じて増やしたり減らしたりしてください

フォルダ作成先

  Dim 作成先 As String: 作成先 = ws2.Cells(1, 1).Value

例ではSettingシートのA1セルにしていますが
自由に変えてください

使い方

ショートカットを設定してもいいし
コマンドボタンを挿入して紐づけてもいいと思います


以上です

記事化自体もかなり雑になってしまいましたし
エラー無視とか手抜きせずにとか
もっと賢く作れないかとか
いろいろあると思いますが
もしよかったら使ってみてください