「今さら」なんてない

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

Excel VBA 情報管理ツールへの拡張:フォルダ一括作成&フォルダを開く

こちらの記事で紹介したExcelタスク管理ツールの補助機能の紹介です。
はじめての方はまずはこちらの記事をどうぞ。 yoshino-ya.hatenablog.com



それでは本題です。

前置き

現在作成中のタスク管理ツール?はタスク管理に留まらず情報管理ツールとしても拡張させたく考えています。

Inboxにその時々でテキトーに投げ込んでおいて後から整理しようとするから無駄やヌケモレが発生するので、タスク登録時にフォルダを作ってしまえば良いのでは、と考え作成しました。

また、フォルダ作成グループは、タスクペディアで言うカテゴリーとしても扱えます。今後配信予定のフィルタリングにもこの列を使います。お楽しみに。

やること

  1. ”マスタ”というシートに”ファイル保存先”をつくる

  2. ”設定”というシートに1の名前とフォルダ作成先のパスを記入する

  3. (報告書pptを同時作成したい方のみ)”pptへの中継ぎ”というシートに報告書ひな形のフルパスを入れておく

    f:id:yoshino-ya:20180619045546p:plain

  4. 下記コードを標準モジュールに貼り付ける

  5. ショートカットを割り当てる

ショートカット割当方法はこちらをどうぞ

yoshino-ya.hatenablog.com

使い方

フォルダ一括作成

選択範囲の1列目の名前のフォルダを作成します。(いったん写真、報告書というフォルダを作成するようになっています)

同時に報告書の作成も行うか問われるので同意するとひな形を利用して報告書のたたき台を作成します。(報告書の転記についての詳細は今回は省略)

フォルダを開く

タスク名の列を選択状態にして起動するとそのフォルダを開きます。

標準モジュールに貼り付けるコード

フォルダ一括作成

Sub フォルダ一括作成()
    On Error Resume Next
    Dim フォルダ作成数 As Integer
    Dim 作成する案件名 As String
    Dim フォルダ参照コード As String
    Dim フォルダ作成を行う行 As Integer
    Dim 現在シート名 As String
    フォルダ作成数 = 0          '初期値
    現在シート名 = ActiveSheet.Name
    
'実行するか確認
    Dim rc1 As Integer, rc2 As Integer
    rc1 = MsgBox("選択範囲のフォルダを作成します。作成先ディレクトリの用意はよろしいですか? 作成する(Y)、ちょっと待った(N)", vbYesNo + vbQuestion, "確認")
    rc2 = MsgBox("報告書pptファイルの作成はせずにフォルダ作成のみ行いますか? フォルダのみ作成(Y)、報告書pptも作成する(N)", vbYesNo + vbQuestion, "確認")
    If rc1 = vbYes Then
        If rc2 = vbYes Then
            xls2pptを実行するか否か = False
            MsgBox "フォルダを作成します。"
        Else
            xls2pptを実行するか否か = True
            MsgBox "フォルダおよびpptファイルを作成します。"
        End If
    Else
        Exit Sub
    End If
    
'ループ
    '選択範囲から実行範囲の指定
    row_start = Selection(1).Row
    row_end = Selection(Selection.Count).Row
    選択範囲最初の列 = Selection(1).Column
    
    フォルダ作成を行う行 = row_start
        Application.Wait Now + TimeValue("00:00:01")

    Do While フォルダ作成を行う行 <= row_end
        作成する案件名 = Sheets("マスタ").Cells(フォルダ作成を行う行, 選択範囲最初の列).Value
        フォルダ参照コード = Cells(フォルダ作成を行う行, "K").Value
        If フォルダ参照コード = "" Then
            MsgBox "ファイル保存先コードが未登録です。" & vbCrLf & _
            "シート(設定) > テーブル(ファイル保存先) のルールに従って登録して下さい。"
            Cells(フォルダ作成を行う行, "K").Select
            Exit Sub
        End If
        
    '空白セルは除外して次の行へ進める
        If 作成する案件名 <> "" Then
            'マスタ現在行の「フォルダ保存先」を設定から検索する
            Sheets("設定").Select
            Set FoundCell = Range("G:G").CurrentRegion _
            .Find(What:=フォルダ参照コード)
            If FoundCell Is Nothing Then
                MsgBox "フォルダ参照コードの検索に失敗しました。" & vbCrLf & _
                        "処理を中止します。"
                Exit Sub
            End If
    
            '検索結果(フォルダパス)を保存先に設定する
                保存先 = Sheets("設定").Cells(FoundCell.Row, "H").Value
                MkDir 保存先 & "\" & 作成する案件名                 '作成するフォルダ名
                MkDir 保存先 & "\" & 作成する案件名 & "\報告書"     '作成するフォルダ名
                MkDir 保存先 & "\" & 作成する案件名 & "\写真"       '作成するフォルダ名
                
            If xls2pptを実行するか否か = True Then
                'pptひな形も保存してしまう
                    報告書名 = Sheets("pptへの中継").Range("L7").Value
                                        コピー元 = Sheets("pptへの中継").Range("L10").Value
                    コピー先 = 保存先 & "\" & 作成する案件名 & "\報告書" & "\"
                '既にpptファイルがある場合上書きしてしまうので既に存在する場合は実行しない
                    If Dir(コピー先 & 報告書名 & buf & ".pptx") = "" Then
                        FileCopy コピー元, コピー先 & 報告書名 & 作成する案件名 & ".pptx"
                    End If
                
'                'ppt報告書を品目一覧から転記する
'                    試験名 = 作成する案件名
'                    Call マスタからppt雛形へ転記する
            End If
            
            '元のセルに戻る
                Sheets(現在シート名).Select
                フォルダ作成数 = フォルダ作成数 + 1
        End If
        
    '変数加算:結合セルサイズ分進める(結合セル2行目の空白で上の警告に引っかかるのを回避する)
    フォルダ作成を行う行 = フォルダ作成を行う行 + Cells(フォルダ作成を行う行, 選択範囲最初の列).MergeArea.Count
    Loop
    
'完了通知
MsgBox フォルダ作成数 & "個分のフォルダを作成しました"
End Sub

フォルダを開く

Sub 選択セルの名前のフォルダを開く()

    Dim 開こうとするフォルダ名 As String

    '画面更新非表示
        Application.ScreenUpdating = False

    '前置き
        現在シート名 = ActiveSheet.Name
        開こうとするフォルダ名 = ActiveCell.Value
        フォルダ参照コード = Cells(ActiveCell.Row, "K").Value
        
    'マスタ現在行の「フォルダ保存先」を設定から検索する
        Sheets("設定").Select
        Set FoundCell = Range("G:G").CurrentRegion _
                .Find(What:=フォルダ参照コード)
                
    '検索結果(フォルダパス)を保存先に設定する
        保存先 = Sheets("設定").Cells(FoundCell.Row, "H").Value
    
    '開くフォルダのパスを決定する
        buf = 保存先 & "\" & 開こうとするフォルダ名
        
    'フォルダを開く
        Shell "C:\Windows\Explorer.exe " & buf, vbNormalFocus
    
    '元のセルに戻る
        Sheets(現在シート名).Select
    
    '画面更新有効化
        Application.ScreenUpdating = True
        
End Sub

以上です。

セル参照が固定になっているのでまたその辺りは改訂版を出せたらと思います。