シェアする

VBA を使ってフォルダをいっぱい作ろう その1

職場の人:「おーい和休!ちょっと頼みがある」

職場の人:「ここに日付ごとのフォルダを作っておいてくれ。」

「わかりました。」:和休

職場の人:「えーと、今日から1年先の分まで作って。」

「・・・(-“-)まじでかー」:和休


ということで、日付を名前としたフォルダを365個作ることになりました。

こういう処理をしてくれるフリーソフトはあると思いますが、職場のセキュリティポリシーの関係で、勝手にインストールできないことが多いですよね。

かといって、チマチマとフォルダを作ってリネームしていくなんて、日の暮れそうな作業量ですねぇ。

1回きりの作業であれば、手分けしてゴリゴリとやってしまう選択肢もあるでしょうが、こんな作業は繰り返し発生するものです。

ここは、パソコンの作業は、パソコンに任せてしまいましょう。

AccessでもExcelでもいいんですが、VBAを組んで片づけるよ!


まず、作業用のフォルダを出力する場所を決めましょう。

どこでもいいのですが、今日はDドライブにあるTESTフォルダ内を出力先にします。

Dドライブがないパソコンをお使いの場合は、環境に合わせて出力先を変更してください。

Sub waq_mkfld1()

'今日から1年後までの日付を付けたフォルダを作成します。

Dim TgTfldPath As String '出力先のパス
Dim TgTfldName As String 'フォルダの名前
Dim ymd_FR As Date  '開始年月日
Dim ymd_TO As Date  '終了年月日

TgTfldPath = "D:TEST"

'DドライブにTESTフォルダがあるかどうかをチェック
'TESTフォルダがあればフォルダへのパスが返ってくる→次の処理へ進む
' "" が返ってくれば、TESTフォルダは存在しない→DドライブにTESTフォルダを作成する。
If Dir(TgTfldPath, vbDirectory) = "" Then
'同名のフォルダが存在しないとき
    
    MkDir (TgTfldPath) 'フォルダを作成します。
End If


'出力先をDドライブにあるTESTフォルダ内のoutputフォルダとする

TgTfldName = "output" '変数にフォルダ名をセット

TgTfldPath = "D:TEST" & TgTfldName   '変数に出力先をセット

'出力先に同名のフォルダがあるかどうかをチェック
'同名のフォルダがあればフォルダへのパスが返ってくる→出力できないため処理中止とする。
' "" が返ってくれば、同名のフォルダは存在しない→出力可能であるため、DドライブにあるTESTフォルダ内にoutputフォルダを作成する。
If Dir(TgTfldPath, vbDirectory) = "" Then
'同名のフォルダが存在しないとき
    
    MkDir (TgTfldPath) 'フォルダを作成します。
Else
'同名のフォルダが存在するとき

    MsgBox "出力先に同名のフォルダがあります。処理を中止します。", vbCritical
    Exit Sub 'コードの実行を中止します。
End If

'DドライブにあるTESTフォルダ内のoutputフォルダへ連番のフォルダを作成します。

'開始年月日に今日の日付をセットします。
ymd_FR = Date

'終了年月日に1年後の日付をセットします。
ymd_TO = DateAdd("m", 12, Date)

Do

    MkDir (TgTfldPath & "" & Format(ymd_FR, "yyyymmdd")) 'フォルダを作成します
    'TgTfldPathには出力先(DドライブにあるTESTフォルダ内のoutputフォルダ)が代入されています。
    'さらに & を用いてフォルダ名を連結します。
    'Format(ymd_FR, "yyyymmdd")) により、20170428 という西暦8ケタの表示に変換します。
    
    ymd_FR = ymd_FR + 1  '1日加算します

Loop Until ymd_FR = ymd_TO  ' 変数 ymd_FRと変数 ymd_TO の値が同じになるまで処理をループさせます。

End Sub

以上のコードを標準モジュールに記述し、実行してみてください。

DドライブのTESTフォルダを開けてみましょう。

ハイ!フォルダが365個できあがってますね!成功です。(^^)v

シェアする

フォローする