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

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

 

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

 

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

 

<ツール更新履歴>

(2022年5月12日:更新)

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

(2022年9月19日:更新)

・振り分けるファイル/フォルダの指定にワイルドカードを使用できるように変更しました。それに伴い指定するファイルは拡張子まで記載するように仕様を変更しました。

(2022年9月30日:更新)

・同一名称のファイルが存在する場合に、当該ファイル/フォルダの処理をスキップするか、上書き保存するかを選択できるようにする仕様へ変更しました。
・全体のUIを変更しました。

 

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

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

 

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

当ツールの使用方法

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

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

 

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

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

 

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

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

 

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

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

 

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

 

更に下の階層にあるフォルダにもワイルドカードを使用した指定したファイルやフォルダが振り分けられました。

 

Option

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

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

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

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

Option3:同一名称のファイルが既に存在する場合の処理を指定

同一ファイルに対して、スキップするか上書き保存するか選択できます。

 

ワイルドカードが使用可能

振り分ける先の「ファイル/フォルダ」にはワイルドカード(*、?など)を使用できます

 

留意事項

フォルダ名称の記載箇所ルール

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

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

 

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

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

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

 

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

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

 

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

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

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

 

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

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

 

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

 

使用する際の事前準備

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

 

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

 

準備の手順

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

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

 

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

 

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

 

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

 

VBAのソースコードはこちら

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

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

Option Explicit

'-----(設定値)------------------------
Private Const START_DATA_COL_NUM = 1            '1.ファイル振り分け表のデータ部の開始列
Private Const START_DATA_ROW = 10               '2.ファイル振り分け表のデータ部の開始行
Private Const END_DATA_COL_NUM = 10             '3.ファイル振り分け表の最終列の列位置
Private Const SETTING_TARGET_POINT = "B3"       '4.振り分け対象設定のセル位置
Private Const SETTING_DELETE_POINT = "C3"       '5.振り分け元ファイルの削除設定のセル位置
Private Const SETTING_ISPROCESS_POINT = "D3"    '6.既にファイルが存在する場合の処理のセル位置
Private Const PATH_DELIMITER = "\"              '7.パスの区切り文字
Private Const SETTING_SHEET_NM = "setting"      '8.設定シート名

'-----(メッセージ)-------------------
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 DoDel As Boolean                    '振り分け元ファイルの削除有無
Private TgtObj As Long                      '振り分け対象(0:フォルダとファイル、1:ファイルのみ、2:フォルダのみ)
Private DoProcess As Long                   '既に存在する場合の処理(true:上書き保存、false:スキップ)

'===========================================
'ファイル振り分けを実行した際のメイン処理
'===========================================
Sub ファイル振り分け実行_Click()
    
    On Error GoTo err
    
    Dim shapeNm As String: shapeNm = Application.Caller
    ActiveSheet.Shapes(shapeNm).Visible = False     'ボタンを非表示にして押し込む動作をつける
    
    Call initialize
    
    'ダイアログを表示させて、開くを押したときだけ処理する
    If folderSelect Then
        Call fileSorting

        If BlnErrFlg Then
            MsgBox WMsg1
        Else
            MsgBox Msg1
        End If
        
    End If
    
    ActiveSheet.Shapes(shapeNm).Visible = True  '押し込んだボタンを戻す
    
    Exit Sub
err:
    MsgBox EMsg1
    
    ActiveSheet.Shapes(shapeNm).Visible = True  '押し込んだボタンを戻す
    
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
    
    With Worksheets(SETTING_SHEET_NM)
    
        If .Range(SETTING_DELETE_POINT).Value = "削除する" Then
            DoDel = True
        Else
            DoDel = 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
        
        If .Range(SETTING_ISPROCESS_POINT).Value = "上書き保存" Then
            DoProcess = True
        Else
            DoProcess = False
        End If
        
    End With
    
    BlnErrFlg = False
    
End Sub

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

End Function

'-------------------------------------
'ファイル振り分けの処理を行う
'-------------------------------------
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 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 = PATH_DELIMITER & folderNm
                    Case 2
                        layerNm2 = Cells(row, colFolder)
                        folderPath = PATH_DELIMITER & layerNm1 & _
                                        PATH_DELIMITER & folderNm
                    Case 3
                        layerNm3 = Cells(row, colFolder)
                        folderPath = PATH_DELIMITER & layerNm1 & _
                                        PATH_DELIMITER & layerNm2 & _
                                            PATH_DELIMITER & folderNm
                    Case 4
                        layerNm4 = Cells(row, colFolder)
                        folderPath = PATH_DELIMITER & layerNm1 & _
                                        PATH_DELIMITER & layerNm2 & _
                                            PATH_DELIMITER & layerNm3 & _
                                                PATH_DELIMITER & folderNm
                    Case 5
                        layerNm5 = Cells(row, colFolder)
                        folderPath = PATH_DELIMITER & layerNm1 & _
                                        PATH_DELIMITER & layerNm2 & _
                                            PATH_DELIMITER & layerNm3 & _
                                                PATH_DELIMITER & layerNm4 & _
                                                    PATH_DELIMITER & folderNm
                End Select
                
                '指定された格納先フォルダが存在しない場合はエラーとする
                If Dir(ThisWorkbook.Path & folderPath, vbDirectory) = "" Then
                    Cells(row, colFolder).Font.ColorIndex = 3
                    BlnErrFlg = True
                    Exit For
                End If
            End If
            
            'ファイル名に値が入っている場合
            If fileNm <> "" Then
                
                '振り分けるファイル/フォルダが存在しない場合はエラーとする
                If Dir(ImportDir & PATH_DELIMITER & fileNm, vbDirectory) = "" Then
                
                    Cells(row, colFile).Font.ColorIndex = 3
                    BlnErrFlg = True
                    
                    Exit For
                End If
                
                Dim tgtFileOrFolder As String
                tgtFileOrFolder = Dir(ImportDir & PATH_DELIMITER & fileNm, vbDirectory)
                
                'ワイルドカードを使用している場合は、存在するファイル/フォルダ数分だけ処理をする
                Do While tgtFileOrFolder <> ""
                        
                    '振り分け先に同一名称のファイル/フォルダが存在する場合
                    If fso.FileExists(ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder) Or _
                        fso.folderExists(ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder) Then
                        
                        '上書き保存する場合のみ処理する
                        If DoProcess = True Then
                    
                            '「フォルダ」を振分け対象にした場合、フォルダ振分け処理をする
                            If (GetAttr(ImportDir & PATH_DELIMITER & tgtFileOrFolder) And vbDirectory) = vbDirectory And _
                                (TgtObj = 0 Or TgtObj = 2) Then
                        
                                If DoDel Then  'ファイル/フォルダを振分け後に削除する場合
                                
                                    Call fso.DeleteFolder(ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder, True)
                                    Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
                                            ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder
                                
                                Else
                                
                                    Call fso.CopyFolder(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
                                                    Destination:=ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder)
                                
                                End If
                                
                            'フォルダ以外(≒ファイルのみ)かつ処理対象が「ファイル」を含む場合に振分け処理をする
                            ElseIf GetAttr(ImportDir & PATH_DELIMITER & tgtFileOrFolder) <> vbDirectory And _
                                        (TgtObj = 0 Or TgtObj = 1) Then
                                        
                                If DoDel Then  'ファイル/フォルダを振分け後に削除する場合
                                
                                    Call fso.DeleteFile(ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder, True)
                                    Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
                                            ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder
                                Else
                            
                                    Call fso.CopyFile(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
                                                        Destination:=ThisWorkbook.Path & folderPath & PATH_DELIMITER)
                                End If
                            End If
                            
                        End If
                        
                    Else    '同一名称のファイル/フォルダが存在しない場合
                        
                        '「フォルダ」を振分け対象にした場合、フォルダ振分け処理をする
                        If (GetAttr(ImportDir & PATH_DELIMITER & tgtFileOrFolder) And vbDirectory) = vbDirectory And _
                                (TgtObj = 0 Or TgtObj = 2) Then
                        
                            If DoDel Then  'ファイルを振分け後に削除する場合
                                
                                Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
                                        ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder
                                    
                            Else
                            
                                Call fso.CopyFolder(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
                                        Destination:=ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder)
                            End If
                        
                        'フォルダ以外(≒ファイルのみ)かつ処理対象が「ファイル」を含む場合に振分け処理をする
                        ElseIf GetAttr(ImportDir & PATH_DELIMITER & tgtFileOrFolder) <> vbDirectory And _
                                (TgtObj = 0 Or TgtObj = 1) Then
                        
                            If DoDel Then  'ファイルを振分け後に削除する場合
                                
                                Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
                                        ThisWorkbook.Path & folderPath & PATH_DELIMITER & tgtFileOrFolder
                                    
                            Else
                        
                                Call fso.CopyFile(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
                                                    Destination:=ThisWorkbook.Path & folderPath & PATH_DELIMITER)
                            End If
                            
                        End If
                    End If
                    tgtFileOrFolder = Dir()
                Loop
            End If
        Next col
    Next row
    
    Set fso = Nothing
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」のマクロを設定します。

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

 

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

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

 

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

 

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

 

正常に動作しない場合は、コメントいただければ幸いです。
また、このような業務効率化できるツールを以下に一覧でまとめてありますので、ご興味のある方はご覧ください。

 

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

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

 

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

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

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

 

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

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

  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を変えて試した所、問題なく処理出来ました。

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

  7. かき より:

    すみません、間違って違うとこにコメント載せちゃってたので再記しますm(_ _)m

    はじめまして、こちらのツール大変便利に活用させていただいています。
    vba独学初心者なのですが、操作の手間を削減するためにダイアログからのフォルダを指定せず、振り分けファイルのパスを直接指定してみたのですが上手くいきません
    フォルダセレクトの構文を消して
    Dim ImportDir As String
    ImportDir = フォルダパス
    ではダメでしょうか?何か手だてがあればご教示いただきたいです

    1. RH より:

      管理人のRHです。
      かきさん、ツールを使用いただき、またコメント頂きありがとうございます。

      ダイアログを表示させずに、振り分けるファイルを固定のフォルダで処理する場合は、かきさんのおっしゃる箇所(85~96行目の部分)を修正することで合っています!

      しかし修正する内容としては、以下になります。
      ①「フォルダセレクトの構文を消して」 →記載OK
      ②「Dim ImportDir As String」 →不要
      ③「ImportDir = フォルダパス」 →記載OK

      “ImportDir” は20行目で既に宣言しているので、改めての宣言は不要となります。
      (※この記載があると二重定義になってしまうため)
      そのため②「Dim ImportDir As String」は書かずに、①部分をコメントまたは記載を消していただき、③を追加で記載いただけたら動作すると思います。

      思うように動作しない場合は改めてコメントいただけたらと思います。

      1. かき より:

        できました!!
        とても助かりましたし勉強になりました!!
        返答も早く頂きましてありがとうございました

  8. かい より:

    はじめまして。
    ファイルの自動振り分けができないかネットを彷徨っていた所、こちらを発見し、求めていたモノだと感激し、使わして頂こうかと考えています。
    VBAは初心者なのですが、
    ファイル名に抽象性を持たせる為にはどうしたら良いでしょうか?または可能でしょうか?

    例えば、ファイル名に◯◯を含む場合、このフォルダに移動という挙動にしたいのです。

    ファイル名は、
    日付(20220919)+ユーザー名+種類(「見積り」や「案内」など).拡張子
    で考えています。

    ◯◯は基本的にユーザー名(会社名)となります。

    ユーザー毎にフォルダを一つ割り振っています。

    宜しくお願いします。

    1. RH より:

      管理人のRHです。
      かいさん、ツールを使用いただき、またコメント頂きありがとうございます。

      ファイルに抽象性を持たせる場合は、例えばアスタリスクを用いてワイルドカードを使用させる等の動作になると思います。
      しかし、申し訳ありませんが、現時点ではツールは対応していません。
      >ファイル名に抽象性を持たせる為にはどうしたら良いでしょうか?または可能でしょうか?

      抽象的なファイル名等の指定にしても動作するように改修いたしますので、少々お待ちいただいて良いでしょうか。

      1. 匿名 より:

        RH様

        返信ありがとうございます!
        対応できないのですね。

        自分でも勉強しつつ、
        改修心待ちにしております!

        1. RH より:

          管理人のRHです。
          かいさん、コメント頂きありがとうございます。

          お待たせいたしました。ファイルに抽象性を持たせて指定した際に動作するよう9月19日に改修いたしました。

          例えば、
          「20220919_user1_見積り.xlsx」の命名ルールのファイルがあった場合に「ファイル/フォルダ」の項目に「*_user1_*.xlsx」と入力すれば、ユーザー毎に作られたフォルダにファイルを振り分けることができるかと思います。

          思うように動作しない場合は改めてコメントいただければと思います。

  9. めかぶ より:

    はじめまして。ファイルをフォルダに振り分けるVBAができないかと思い探していたところこちらにたどり着きました。まさに自分のやりたかったことと近く、感激しております。

    もしよろしければご教示いただきたいのですが、

    ファイル名が【取引先名_発注ナンバー_日付.xlsx】の発注書を毎日大量に作成しているため、ワイルドカードを使用して、作成済みの発注書を取引先名フォルダに自動振り分けするようにしたいと考えているのですが、振り分けるファイル名を*取引先*.xlsxで指定した場合、振り分け先に同じ名称のファイルがあるということでエラーになってしまうのですが何か方法はないでしょうか?

    A社_0001_0928
    A社_0002_0929
    A社_0003_1001

    →A社フォルダに随時蓄積

    よろしくお願いいたします。

    1. RH より:

      管理人のRHです。
      めかぶさん、ツールの使用とコメントありがとうございます。

      現象について、もう少し詳しくお聞きしたいのですが、
      当方の環境で以下のファイルを作成して、「*A社*.xlsx」でファイル振り分け処理を行ってみたところ、正常に振り分けが完了しましたが、めかぶさんが行った操作と違ってますでしょうか?
      ・A社_0001_0928.xlsx
      ・A社_0002_0929.xlsx
      ・A社_0003_1001.xlsx

      また、質問の意図としては、既に存在するファイルも含めて割り振りたいということをご希望でしょうか。
      例)既にファイルがある場合は上書き保存する。(or 当該ファイルはスキップして他のファイルは振り分けるようにする)

  10. めかぶ より:

    RH様
    ご確認ありがとうございます。
    わかりにくくて申し訳ありません。

    下記のような流れで活用できればと思っております。

    ・9/29
    当日作成したファイルを「振り分け用」フォルダに入れ、各メーカー名のフォルダに振り分け(「振り分け用」フォルダのファイルは全削除)

    ・9/30
    当日作成したファイルを「振り分け用」フォルダに入れ、各メーカー名のフォルダに振り分け(「振り分け用」フォルダのファイルは全削除)

    上記要領で各メーカー名のフォルダにどんどんファイルを蓄積していく…
    (ファイル名はA社_XXXX_MMDD.xlsでメーカー名のみ不変)

    一度に振り分けを行う場合、処理できるのですが、
    「A社_0001_0928」を「A社」フォルダに移動した後、「A社_0002_0929」を「A社」フォルダに移動しようとするとエラーになる状態です。(振り分け元のフォルダには「A社_0002_0929」のみ、振り分け先のフォルダには「A社_0001_0928」が入っている状態)

    1. RH より:

      管理人のRHです。
      めかぶさん、コメントありがとうございます。

      すいません、そういうことですね。理解致しました。
      二回に分けて同格納フォルダに振り分け実行した場合に、うまく動作しないとお見受けしました。わたしの環境でも同様の操作をしてみたところエラーメッセージが表示され正常に動作しませんでした。申し訳ありません、ツールの不具合でした。

      本日(2022年9月30日付)、複数回に分けて同様の格納先フォルダにワイルドカードを使用して実行させても動作するよう不具合を修正しましたので、改めてご使用いただけますと幸いです。(※全体のUIも少し変更しましたのでご了承ください。)

      思うように動作しない場合は改めてコメントいただければと思います。

  11. めかぶ より:

    RH様

    ご対応ありがとうございます。

    試してみたところ、希望していた通りの処理ができました!

    時間がかかっていた作業を効率化できそうです。
    本当にありがとうございます。

    1. RH より:

      管理人のRHです。
      めかぶさん、コメントありがとうございます。

      業務の効率化ができるようになったようで、大変喜ばしく思います。
      また他のツールも是非ご使用いただけたら幸いです。

コメントを残す

CAPTCHA