【Excel VBA】ファイル自動振り分けツール(コピペですぐ使える)

 

 

日常業務を行うにあたって、たくさんあるファイルをいくつかのフォルダへ自動で簡単に振り分けることができたら良いと思います。

 

その際にエクセルの表で記載したフォルダパスへファイルを自動で振り分けることができたら良いなと考え(記事を見て頂いた方からコメントを頂きました)、ファイル振り分けを自動的に行うマクロを作成しましたのでご活用頂けたらと思います。

 

このファイル自動振り分けマクロは、他ツールのフォルダ自動作成マクロを用いて振り分けるフォルダを自動生成した後に使用すると良いと思います。

 

<更新履歴>

(2022年5月12日:更新) 設定として、「対象をフォルダ/ファイルにするか」と「振り分けた後のファイル等を削除するか」を指定できるように変更しました。また、ツールの説明文を1行目に追加、ツールの全体構成の変更、フォルダ名称入力時に同一行をグレーアウトする仕様に変更しました。

 

ファイル自動振り分けマクロの概要

エクセルに振り分け先のフォルダ名と、振り分けるファイル名を記入してマクロを実行すると、指定したパスのフォルダにファイルを自動で振り分けされます。

 

ExcelにてVBAコードよりマクロを作成し、ボタン(図形にて作成)をクリックすることでマクロを実行させてファイル振り分け処理を実施します。

当ツールの使用方法

基本的な機能、操作方法の説明

1.ファイル自動振り分けツールのVBAコードを含んだExcelファイル(***.xlsm)を任意のフォルダに保存して、そのExcelファイルを開きます。

 

2.開いたExcelファイルに振り分け先フォルダ名と振り分けるファイル名を記載して、「ファイル振り分け実行」ボタンをクリックします。

※当ツールが存在するフォルダの階層は、一番左の列の「格納先フォルダ」と同階層となります

 

3.表示されたダイアログで振り分けるファイルが格納されたフォルダを指定します

正常に実行された場合は、その旨のメッセージが表示されます。

 

4.2で指定した「格納先フォルダ」に対して、指定した「ファイル」が振り分けられています。

※振り分けたファイルを元々格納されていたフォルダ内から削除するかどうかはオプションで選択できます。

 

ツールより下の階層にあるフォルダにも同じくファイルが振り分けられました。

 

Option

Option1:ツール実行時の振り分け対象を指定

対象を「ファイルのみ」、「フォルダのみ」、「ファイルとフォルダ」の中から選択できます。

Option2:振り分け実行後の元ファイルを削除するかを指定

振り分け元にある振り分け前のファイルをツール実行後に削除するかを選択できます。

留意事項

フォルダ名称の記入ルール

「格納先フォルダ」の記載箇所等に関しては、「フォルダ自動作成マクロ」のルールと同様です。

※ 当マクロにはフォルダを自動生成する機能はありませんのでフォルダを作成する場合は、「フォルダ自動作成ツール」を実行してから当ツールを利用ください

 

フォルダ名称とファイル名称を正しいセル位置にそれぞれ記載する

(注意)「格納先フォルダ」と記載された列にはフォルダ名称を記入し、「ファイル」と記載された列にはファイル名称を記入してください。

また、一番左の列(A列)には最初のフォルダ名を記入してください。

 

一つの行に複数のフォルダ名等の指定をしない

(注意)1行で記入できるセルは一つだけです。

 

存在するフォルダと存在するファイルを指定する

指定する「格納先フォルダ」は、既に存在するフォルダの名称と階層を記載してください。

指定する「ファイル」は、振り分けるフォルダ内に存在するファイルを記載して下さい。

 

上記のルールを守っていない行は、ファイル自動振り分けの対象から外れます。

その場合、誤っている箇所を赤色で表示させ、当該行の処理はスキップされます。

 

また、実行後に指定したフォルダが全て作成された場合と、問題箇所がある場合とで、メッセージが異なりますので確認してください。

 

使用する際の事前準備

このページの下部にある「Excelファイルのサンプル」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得したExcelファイルに記載して保存すれば、すぐに当ツールを使用できます。

 

以下にその手順を説明していきます。

 

準備の手順

1.サンプルのダウンロードはこちら」からサンプル(Excelファイル)をダウンロードします。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

2.ダウンロードしたExcelファイルの上部にあるリボンの「開発」タブから「visual basic」を選択して、VBE(Visual Basic Editor)を起動させます。

 

3.「ThisWorkbook」をダブルクリックします。

 

4.表示されている右側の欄(エディター)にVBAコードを記載します。

 

以下のVBAコードを「ThisWorkbook」内のエディターにコピーして貼り付けます。

※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます

Option Explicit

'-----(設定値)------------------------
Private Const START_DATA_COL_NUM = 1        '1.ファイル振り分け表のデータ部の開始列
Private Const START_DATA_ROW = 11           '2.ファイル振り分け表のデータ部の開始行
Private Const END_DATA_COL_NUM = 10         '3.ファイル振り分け表の最終列の列位置
Private Const SETTING_DELETE_POINT = "J6"   '4.振り分け元ファイルの削除設定のセル位置
Private Const SETTING_TARGET_POINT = "G6"   '5.振り分け対象設定のセル位置

'-----(メッセージ)-------------------
Private Const Msg1 = "ファイル振り分け処理が正常に実行されました"
Private Const Msg2 = "振り分けるファイルが入っているフォルダを選択してください。"
Private Const WMsg1 = "赤色で表示された箇所は、下記により正しくファイルを振り分けることができませんでした。" & vbCrLf & vbCrLf _
                        & "フォルダ名:指定されたフォルダ名は存在していません。 " & vbCrLf _
                        & "ファイル名:ダイアログで選択したフォルダ内にファイルが存在しないか、振り分け先に同一名称のファイルが存在しています。"
Private Const EMsg1 = "予期せぬエラーが発生しました、ツール利用ルールを確認してもう一度実行してください。"
'---------------------------------------

Private LngErrRow() As String               'エラーが発生した行数
Private ImportDir As String                 '振り分けるファイルが格納されたフォルダのパス
Private BlnErrFlg As Boolean                'エラーの有無
Private DelFlg As Boolean                   '振り分け元ファイルの削除有無
Private TgtObj As Long                      '振り分け対象(0:フォルダとファイル、1:ファイルのみ、2:フォルダのみ)

'===========================================
'ファイル振り分けを実行した際のメイン処理
'===========================================
Sub ファイル振り分け実行_Click()
    
    On Error GoTo err
    
    Call initialize
    Call folderSelect
    Call fileSorting
    
    'エラーが存在した場合はエラーメッセージを表示させる
    If BlnErrFlg Then
        MsgBox WMsg1
    Else
        MsgBox Msg1
    End If
    
    Exit Sub
err:
    MsgBox EMsg1
    
End Sub

'-------------------------------------
'色の変更、初期化等を行う
'-------------------------------------
Sub initialize()

    Dim iRow As Long
    
    '表の最終行番号を取得する
    iRow = Cells(START_DATA_ROW, START_DATA_COL_NUM).SpecialCells(xlCellTypeLastCell).row

    '表全体の文字色を黒色に変更する
    Range(Cells(START_DATA_ROW, START_DATA_COL_NUM), Cells(iRow, END_DATA_COL_NUM)).Font.ColorIndex = 1
    
    If Range(SETTING_DELETE_POINT).Value = "削除する" Then
        DelFlg = True
    Else
        DelFlg = False
    End If
    
    If Range(SETTING_TARGET_POINT).Value = "ファイルとフォルダ" Then
        TgtObj = 0
    ElseIf Range(SETTING_TARGET_POINT).Value = "ファイルのみ" Then
        TgtObj = 1
    Else
        TgtObj = 2
    End If
    
    BlnErrFlg = False
    
End Sub

'-------------------------------------
'振り分けるファイルが入っているフォルダを選択する
'-------------------------------------
Sub folderSelect()
    
    'フォルダ選択ダイアログを表示させる
    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .Title = Msg2
        
        If .Show <> 0 Then
            ImportDir = .SelectedItems(1)
        Else
            End
        End If
    
    End With

End Sub

'-------------------------------------
'ファイル振り分けの処理を行う
'-------------------------------------
Sub fileSorting()

    Dim row As Long
    Dim col As Long
    Dim colFolder As Long
    Dim colFile As Long
    
    Dim folderNm As String
    Dim folderPath As String
    Dim fileNm As String
    Dim tmpFileNm As String
    
    Dim layerNm1 As String
    Dim layerNm2 As String
    Dim layerNm3 As String
    Dim layerNm4 As String
    Dim layerNm5 As String
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'フォルダ名称、ファイル名称が記載されている行数分だけ繰り返す
    For row = START_DATA_ROW To Cells(START_DATA_ROW, START_DATA_COL_NUM).SpecialCells(xlCellTypeLastCell).row
    
        'フォルダ名称、ファイル名称が記載されている列数分だけ繰り返す
        For col = 1 To 5
            
            'フォルダ名称が入っている列番号
            colFolder = col * 2 - 1
            
            'ファイル名称が入っている列番号
            colFile = col * 2
            
            folderNm = Cells(row, colFolder)
            fileNm = Cells(row, colFile)
            
            'フォルダ名に値が入っている場合、フォルダーパスを取得する
            If folderNm <> "" Then
                Select Case col
                    Case 1
                        layerNm1 = Cells(row, colFolder)
                        folderPath = folderNm
                    Case 2
                        layerNm2 = Cells(row, colFolder)
                        folderPath = "/" & layerNm1 & "/" & folderNm
                    Case 3
                        layerNm3 = Cells(row, colFolder)
                        folderPath = "/" & layerNm1 & "/" & layerNm2 & "/" & folderNm
                    Case 4
                        layerNm4 = Cells(row, colFolder)
                        folderPath = "/" & layerNm1 & "/" & layerNm2 & "/" & layerNm3 & "/" & folderNm
                    Case 5
                        layerNm5 = Cells(row, colFolder)
                        folderPath = "/" & layerNm1 & "/" & layerNm2 & "/" & layerNm3 & "/" & layerNm4 & "/" & folderNm
                End Select
            End If
            
            'ファイル名に値が入っている場合
            If fileNm <> "" Then
            
                '指定された格納先フォルダが存在しない場合はエラーとする
                If Dir(ThisWorkbook.Path & "/" & folderPath, vbDirectory) = "" Then
                    Cells(row, colFolder).Font.ColorIndex = 3
                    BlnErrFlg = True
                    Exit For
                End If
                
                '指定したファイル/フォルダに合わせて、ファイル名またはフォルダ名を取得する
                '※同一名称のファイル名とフォルダ名が存在する場合は、ファイル名を取得する
                If TgtObj = 1 Then
                    fileNm = Dir(ImportDir & "/" & fileNm & ".*")
                ElseIf TgtObj = 2 Then
                    fileNm = Dir(ImportDir & "/" & fileNm, vbDirectory)
                Else
                    If Dir(ImportDir & "/" & fileNm & ".*") = "" Then
                        fileNm = Dir(ImportDir & "/" & fileNm, vbDirectory)
                    Else
                        fileNm = Dir(ImportDir & "/" & fileNm & ".*")
                    End If
                End If
                
                '指定されたファイル名が存在しない場合、または既にファイルが存在する場合はエラーとする
                If fileNm = "" Or Dir(ThisWorkbook.Path & "/" & folderPath & "/" & fileNm) <> "" Then
                    Cells(row, colFile).Font.ColorIndex = 3
                    BlnErrFlg = True
                Else
                    
                    '指定したファイル/フォルダが「フォルダ」である場合
                    If (GetAttr(ImportDir & "/" & fileNm) And vbDirectory) > 0 Then
                        If TgtObj = 0 Or TgtObj = 2 Then
                            If DelFlg Then
                                Name ImportDir & "/" & fileNm As ThisWorkbook.Path & "/" & folderPath & "/" & fileNm
                            Else
                                fso.CopyFolder Source:=ImportDir & "/" & fileNm, Destination:=ThisWorkbook.Path & "/" & folderPath & "/" & fileNm
                            End If
                        End If
                        
                    '指定したファイル/フォルダが「ファイル」である場合
                    Else
                        If TgtObj = 0 Or TgtObj = 1 Then
                            If DelFlg Then
                                Name ImportDir & "/" & fileNm As ThisWorkbook.Path & "/" & folderPath & "/" & fileNm
                            Else
                                FileCopy ImportDir & "/" & fileNm, ThisWorkbook.Path & "/" & folderPath & "/" & fileNm
                            End If
                        End If
                    End If
                End If
                
                Exit For
            End If
        Next col
    Next row
End Sub

'===========================================
'当ファイルのエクセル内の値を変更した後に実行する処理
'===========================================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim i, iCol, iRow As Long
    Dim selSRow, selERow As Long
    Dim existFlg As Boolean
    
    selSRow = Range(Selection.Rows(1).Address).row
    selERow = Range(Selection.Rows(Selection.Rows.Count).Address).row
    
    iCol = Target.Column
    iRow = Target.row
    
    If selSRow = selERow Then
        selSRow = iRow
        selERow = iRow
    End If
    
    '変更したセルが表内に入っている場合は、同一行の他のセルをグレーアウトする
    If iRow >= START_DATA_ROW And iCol <= END_DATA_COL_NUM Then
    
        For iRow = selSRow To selERow
            For i = 1 To 5
                If ActiveSheet.Cells(iRow, 2 * i).Value <> "" Or ActiveSheet.Cells(iRow, (2 * i) - 1).Value <> "" Then
                    ActiveSheet.Range(Cells(iRow, 2 * i), Cells(iRow, (2 * i) - 1)).Interior.Color = RGB(255, 255, 255)
                    existFlg = True
                Else
                    ActiveSheet.Range(Cells(iRow, 2 * i), Cells(iRow, (2 * i) - 1)).Interior.Color = RGB(220, 220, 220)
                End If
            Next
            
            If existFlg = False Then
                ActiveSheet.Range(Cells(iRow, 1), Cells(iRow, 10)).Interior.Color = RGB(255, 255, 255)
            End If
            existFlg = False
        Next
        
    End If
    
End Sub

 

4.ファイルを保存する際は「Excelマクロ有効ブック」を選択して、保存します。

 

「ファイル振り分け実行」ボタンに「ThisWorkbook.ファイル振り分け実行_Click」のマクロを設定します。

 

6.「ファイル振り分け実行」にカーソルを当てて、指の形になっているのを確認してクリックします。

左のセルに記入されたフォルダ名でフォルダが自動作成されます。

 

これで事前準備は完了です。

あとは「当ツールの使用方法」で記載された方法でツールを実行できます。

また、このようなExcelVBAを用いた業務効率化を行うときに、以下の書籍が初心者向けでとても参考になると思いますので、良かったらご参照ください。

 

なお、当マクロの開発環境として、OSは “Windows10” 、Excelのバージョンは “Microsoft Office 365″ で行っており、当環境では動作確認ができていますが、他のすべての環境で正常に動作するかは確認できていません。

 

正常に動作しない場合は、コメントいただければ幸いです。

 

サンプルのダウンロードはこちら

 【Excel_VBA】ファイル自動振り分けツール

 

上記よりダウンロードして、記事の途中にありましたVBAコードを組み込んでツールを使用してください。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います

 

 

<このツールが『結構使える!』と思ったら、下のグッドボタンを押していただけたら幸いです>

【Excel VBA】ファイル自動振り分けツール(コピペですぐ使える)” に対して15件のコメントがあります。

  1. 茶々 より:

    こんにちは。
    ファイル自動振り分けのマクロを活用させていただいております。
    一つ質問をさせて下さい。

    フォルダ1→フォルダ2→フォルダ3というフォルダ1の中に2階層のフォルダが有り、フォルダ2にファイルA、フォルダ3にファイルBを振分けようとしましたが、うまく行きませんでした。
    フォルダ1にファイルA、フォルダ2にファイルBの振分けは出来ましたので、第1階層のフォルダには必ずファイルを割り当てないと振り分けは出来ないのでしょうか?
    第1階層のフォルダに振り分けずにその中のサブフォルダにファイルを振分けしたいと思っております。

    お手数ですが、振分け方法をご教授いただければと思います。
    宜しくお願い致します。

    1. RH より:

      管理人のRHです。

      当ツールをお使い頂き、また併せて問題をご報告いただき、ありがとうございます。

      確かにおっしゃる通り、第1階層のフォルダには必ずファイルを割り当てないと振り分けができない仕様となっております。恐れ入ります、気が付きませんでした。

      目的を達成するための別の案として、以下の状態で実行してみるとうまくいきますでしょうか。
      1.この自動振り分けマクロのファイルを「フォルダ2」と同階層に配置する。
      2.A2セルには「フォルダ2」を記入し、C列に「フォルダ3」を記入する。
        ※ファイルAはB列、ファイルBはD列となります。

      1. 茶々 より:

        返信ありがとうございます。
        説明不足で申し訳ございませんが、以下の使い方を想定しているのでご提案いただいた方法だとちょっと難しいと思います。

        ・フォルダ1→フォルダ2→フォルダ3のフォルダ2にファイルA、フォルダ3にファイルBを振り分けるというのがフォルダ違いで100パターン程有り、それを同時に処理したいと考えています。
        ・フォルダ1にファイルを振り分ける事も有るが、フォルダ1には振り分けずその中のサブフォルダのみにファイルを振り分ける使い方も有る

        試しにA2セルにフォルダ1、B2セルにダミーのファイル名、C3にフォルダ2、D3にファイルA、E4にフォルダ3、F4にファイルBを入れて実行するとB2セルは当然赤字でエラーになりましたが、フォルダ2、3にファイルの振分けをする事が出来ました。
        このやり方で使おうと思いますが、他に良い方法があれば教えていただけないでしょうか?

        お手数をお掛けしますが、宜しくお願い致します。

        1. RH より:

          管理人のRHです。
          そうでしたか、誤った解釈しておりました申し訳ありませんでした。

          このツールの現状の作りでは、茶々様の言う通りB2にダミーファイル(存在しないファイル)を設定して動かすとそこをスキップして動作するので、ひとまずその方法での使用をお願いします。

          そのような使い方があったとは考えが足りなかったです。B2にファイル指定がない場合でも動くように修正致します。

          1. 茶々 より:

            コメント、ありがとうございます。
            他の質問もありますので新たにコメントさせていただきます

  2. ぽぽぽん より:

    はじめまして。
    ファイルの自動振り分けの検索でこちらにたどり着きました。
    大変参考になります。

    使用してみてエラーというかうまくできない箇所がありましたのでご質問いたします。
    ファイル名で文字数の制限か、規則の制限はありますでしょうか?
    例えば、
    ①a_【asdko1010_10】【見積書】_相手先様_自分の名前
    上記のようなファイル名の場合、”【見積書】”の箇所までのファイル名は振り分けをしてくれるのですが、フルのファイル名だと振り分けのエラーがでてしまいます。
    すみかっこが原因なのか文字数の問題なのかなにか対策ありましたら教えていただけますと幸いです。
    (ファイルの文字数をカウントしたところ59文字前後になりました。)

  3. ぽぽぽん より:

    何度も申し訳ございません。
    先ほど質問させていただいたものです。

    ファイル名は何個試行錯誤してわかったのですが、
    どうやらファイル名のカタカナの濁音に問題があったようです。
    “ジ”が、シと゛に分かれていたのがエラーを起こしてしまう問題のようです。
    カタカナ部分を書き換えたところ無事読込できました。
    お手数おかけして申し訳ありません。
    ありがとうございました。

  4. RH より:

    管理人のRHです。
    当ツールをお使い頂き、ありがとうございます。

    ぽぽぽん様、無事マクロを実行できたということで安心しました、また何かありましたらコメントをお願いします。

  5. 茶々 より:

    度々のコメントで申し訳ございません。
    本ツールではフォルダの振分けは出来ないと思いますが、コードを一部変更してフォルダの振分けをする事は可能でしょうか?
    対応可能な場合、変更内容をご教授いただければと思います。

    マクロ、VBAの知識が無い為、大まかな質問になり申し訳ございませんが、宜しくお願い致します。

    1. RH より:

      管理人のRHです。
      ご質問頂き、ありがとうございます。ご返答が遅くなりました。

      暫定的な対策として、フォルダを振り分けることも可能です。
      その場合は、136行目の「fileNm = Dir(ImportDir & “\” & fileNm & “.*”)」をコメントアウト(先頭に [‘] シングルコーテーションを付ける)していただければひとまずは正常にフォルダを振り分けることができます。

      しかし、136行目をコメントアウトした場合、通常の使い方であるファイルの振り分けを行うことができませんので、ご注意ください。

      >本ツールではフォルダの振分けは出来ないと思いますが、コードを一部変更してフォルダの振分けをする事は可能でしょうか?
      >対応可能な場合、変更内容をご教授いただければと思います。

      後日、改めてファイルとフォルダの両方を振り分け可能なコードを記載したいと思います。

      1. 茶々 より:

        回答ありがとうございます。
        教えていただいた暫定対策で無事フォルダの振分けが出来ました。
        多くのフォルダを扱うので、本当に助かりました。

        1. RH より:

          管理人のRHです。
          いえ、無事目的が達成されたとのことでよかったです。

          また何か作業効率化において必要な機能等がありましたら、ファイル自動振り分けツールとは関係ないものでも良いので、ご要望いただければと思います。

  6. 茶々 より:

    こんにちは。
    ファイル自動振り分けのマクロについてまた質問をさせていただきます。

    フォルダ名によってはこのマクロに対応が出来ないという事はありますか?
    フォルダ名が赤くなるエラーが発生し、見直してもフォルダ名は間違っておらず、コピー貼り付けでフォルダ名を再度入れ直してもやはりエラーになってしまいます。
    フォルダ名とファイル名は以下の通りになります。

    ・行2 フォルダ1:営業所別 ファイル1:1
    ・行3 フォルダ2:東京_6243 ファイル2:6243_東京
    ・行4 フォルダ1:営業所別 ファイル1:2
    ・行5 フォルダ2:南東京_6246 ファイル2:6246_南東京

    以前よりこのマクロを使用しており、別のパターンで使用しようと試した所、エラーが発生しました。
    お手数ですが、アドバイスをいただければと思います。

    宜しくお願い致します。

    1. RH より:

      管理人のRHです。
      返信が遅くなり、申し訳ありません。

      ファイルを振り分けるために動作させたかと思いますが、おっしゃっていただいた以下のフォルダ構成とファイルを用意し、当マクロを実行させた場合は、私が使っている環境ですと正常に動作し、振り分けが完了しました。

      >・行2 フォルダ1:営業所別 ファイル1:1
      >・行3 フォルダ2:東京_6243 ファイル2:6243_東京
      >・行4 フォルダ1:営業所別 ファイル1:2
      >・行5 フォルダ2:南東京_6246 ファイル2:6246_南東京

      フォルダ名が赤くなるということは、通常考えられるのは指定したフォルダが存在していない、または指定した階層にフォルダが存在していない可能性が高そうです。
      コピー貼り付けでフォルダ名を指定頂いたとのことなので、もしかするとフォルダが存在する階層が原因かもしれません。今一度ご確認いただけますでしょうか。

      そして、まだ正常に動作しないようなら、可能なら茶々様のexcelのバージョンなどを教えていただいてよいでしょうか。

      1. 茶々 より:

        こちらこそ返信が大変遅くなり、申し訳ございませんでした。
        具体的な原因は分かりませんが、PCを変えて試した所、問題なく処理出来ました。

        ご確認いただき、ありがとうございました。

コメントを残す

CAPTCHA