日常業務を行うにあたって、たくさんあるファイルをいくつかのフォルダへ自動で簡単に振り分けたいと思うこともある良いと思います。
その際にエクセルの表で記載したフォルダパスへファイルを自動で振り分ける場合は以下のような作業を行っていないでしょうか。
- ファイルが存在するフォルダに移動する。
- 対象のファイルを切り取り（Ctrl+X）をする。
- 移動させたい先のフォルダに移動する。
- フォルダ内で貼り付け（Ctrl+V）をする。
上記の作業を、例えば色々なフォルダ内に散らばって存在するファイルを移動させたい場合は、これらの作業を何度も行う必要があります。
このような大変な作業を自分の時間を削って、何度も何度も繰り返し行っていては、時間が非常にもったいないです。
そんな場面で、無駄な作業が効率化できる、振り分けるファイル（またはフォルダ）と振り分け先のフォルダを階層ごとに指定して一度に振り分ける『ファイル自動振り分けマクロツール』をExcel VBAで作りました。（※他の記事を見て頂いた方から作成の要望コメントを頂きました。）
当記事にはマクロの元になるExcelファイルがダウンロード可能で、VBAのコードも記事内に記載がありますので、Excel VBAやマクロが良く分からないという方でもすぐに使用できます。
当ツールを使用すれば定例業務の業務効率化が図れるかと思いますので、是非ご活用頂けたらと思います。
なお、このファイル自動振り分けマクロツールは、必要に応じて『フォルダ自動作成マクロツール』を用いて振り分けるフォルダを自動生成した後に使用すると効率化が図れると思います。
（2022年5月12日：更新）
・設定として、「対象をフォルダ/ファイルにするか」と「振り分けた後のファイル等を削除するか」を指定できるように変更しました。また、ツールの説明文を1行目に追加、ツールの全体構成の変更、フォルダ名称入力時に同一行をグレーアウトする仕様に変更しました。
（2022年9月19日：更新）
・振り分けるファイル/フォルダの指定にワイルドカードを使用できるように変更しました。それに伴い指定するファイルは拡張子まで記載するように仕様を変更しました。
（2022年9月30日：更新）
・同一名称のファイルが存在する場合に、当該ファイル/フォルダの処理をスキップするか、上書き保存するかを選択できるようにする仕様へ変更しました。
・全体のUIを変更しました。
（2022年12月4日：更新）
・ツール実行時の振り分け先フォルダを選択できるように変更しました。
ファイル自動振り分けマクロの概要
エクセルに振り分け先のフォルダ名と、振り分けるファイル名（またはフォルダ名）を記入してマクロを実行します。
実行すると、指定した階層のフォルダにファイル（またはフォルダ）が自動で振り分けられます。その際に、振り分けた後の元ファイル等を残すか消すかなどを状況に応じて選択することができます。
基本的な機能、操作方法の説明
＜手順１＞
- ファイル自動振り分けツールのVBAコードを含んだExcelファイル（***.xlsm）を任意のフォルダに保存して、そのExcelファイルを開きます。
＜手順２＞
- 開いたExcelファイルに振り分け先フォルダ名と振り分けるファイル名（またはフォルダ名）を記載します。
- 「ファイル振り分け実行」ボタンをクリックします。
※当ツールが存在するフォルダの階層は、一番左の列（B列）の「格納先フォルダ」と同階層となります
＜手順３＞
- 表示されたダイアログで振り分けるファイルが格納されたフォルダを指定します。
正常に実行された場合は、その旨のメッセージが表示されます。
正常に実行された場合は、上記で指定した「振り分け先フォルダ」へ指定した「ファイル」が振り分けられています。
※振り分けたファイルを元々格納されていたフォルダ内から削除するかどうかはオプションで選択できます。
ツールより下の階層にあるフォルダにも同じくファイルが振り分けられました。
更に下の階層にあるフォルダにもワイルドカードを使用した指定したファイルやフォルダが振り分けられました。
Option1：ツール実行時の振り分け対象を指定
対象を「ファイルのみ」、「フォルダのみ」、「ファイルとフォルダ」の中から選択できます。
Option2：振り分け実行後の元ファイルを削除するかを指定
振り分け元にある振り分け前のファイルをツール実行後に削除するかを選択できます。
Option3：同一名称のファイルが既に存在する場合の処理を指定
同一ファイルに対して、スキップするか上書き保存するか選択できます。
振り分け先フォルダを指定可能
「振り分け先パス」の右にあるセルをダブルクリックして表示されたダイアログより振り分け先パスを指定できます。
※セル内に値がない場合は、ツールと同階層を対象にして動作します。
ワイルドカードが使用可能
振り分ける先の「ファイル/フォルダ」にはワイルドカード（*、?など）を使用できます。
留意事項
フォルダ名称の記載箇所ルール
「格納先フォルダ」の記載箇所等に関しては、「フォルダ自動作成ツール」のルールと同様です。
※当マクロにはフォルダを自動生成する機能はありませんので、ファイル振り分けをする前にフォルダを作成する場合は、「フォルダ自動作成ツール」を実行してから当ツールを利用ください。
フォルダ名称とファイル名称を正しいセル位置にそれぞれ記載する
（注意）「格納先フォルダ」と記載された列にはフォルダ名称を記入し、「ファイル/フォルダ」と記載された列には、振り分けるファイル名称またはフォルダ名称を記入してください。
また、一番左の列（A列）には当ツールと同階層にあるフォルダ名を記入してください。
一つの行に複数のフォルダ名等の指定をしない
（注意）１行で記入できるセルは一つだけです。
存在するフォルダと存在するファイルを指定する
指定する「格納先フォルダ」は、既に存在するフォルダの名称と階層を記載してください。
指定する「ファイル」は、振り分けるフォルダ内に存在するファイルを記載して下さい。
上記のルールを守っていない行は、ファイル自動振り分けの対象から外れます。
その場合、誤っている箇所を赤色で表示させ、当該行の処理はスキップされます。
また、実行後に指定したフォルダが全て作成された場合と、問題箇所がある場合とで、メッセージが異なりますので確認してください。
使用する際の事前準備
このページの下部にある「Excelファイルのサンプル」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得して、Excelファイル内に記載すれば、すぐに当ツールを使用できます。
以下にその手順を説明していきます。
準備の手順
＜手順１＞
- 「サンプルのダウンロードはこちら」から当ツールのシートが入ったExcelファイルをダウンロードします。
※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています。
＜手順２＞
ダウンロードしたExcelファイルを開いて、VBE（Visual Basic Editor）を起動させます。
- Excelファイルの上部にあるリボンの「開発」タブを選択します。
- 「Visual Basic」をクリックして、VBE（Visual Basic Editor）を起動させます。
＜手順３＞
- 「ThisWorkbook」をダブルクリックします。
＜手順４＞
- 表示されている右側の欄（エディター）に以下のVBAコードを記載します。
VBAのソースコードはこちら
以下のVBAコードをコピーして「ThisWorkbook」内のエディターに貼り付けます。
※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます
Option Explicit
'-----（設定値）------------------------
Private Const START_DATA_COL_NUM = 2 '１．ファイル振り分け表のデータ部の開始列
Private Const START_DATA_ROW = 13 '２．ファイル振り分け表のデータ部の開始行
Private Const END_DATA_COL_NUM = 11 '３．ファイル振り分け表の最終列の列位置
Private Const SETTING_TARGET_POINT = "B3" '４．振り分け対象設定のセル位置
Private Const SETTING_DELETE_POINT = "C3" '５．振り分け元ファイルの削除設定のセル位置
Private Const SETTING_ISPROCESS_POINT = "D3" '６．既にファイルが存在する場合の処理のセル位置
Private Const PATH_DELIMITER = "\" '７．パスの区切り文字
Private Const SETTING_SHEET_NM = "setting" '８．設定シート名
Private Const DISTRIBUTE_PATH_POINT = "C5" '９．振り分け先フォルダパス
'-----（メッセージ）-------------------
Private Const Msg1 = "ファイル振り分け処理が正常に実行されました"
Private Const Msg2 = "振り分けるファイルが入っているフォルダを選択してください。"
Private Const Msg3 = "振り分け先のフォルダパス（第一階層の上位フォルダ）を指定してください。"
Private Const WMsg1 = "赤色で表示された箇所は、下記により正しくファイルを振り分けることができませんでした。" & vbCrLf & vbCrLf _
& "格納先フォルダ：指定されたフォルダが存在しません。" & vbCrLf _
& "ファイル/フォルダ：ダイアログで選択したフォルダ内に指定したファイル等が存在しません。"
Private Const EMsg1 = "予期せぬエラーが発生しました、ツール利用ルールを確認してもう一度実行してください。"
'---------------------------------------
Private BaseSht As Worksheet 'ツールの本体シート
Private LngErrRow() As String 'エラーが発生した行数
Private ImportDir As String '振り分けるファイルが格納されたフォルダのパス
Private ExportDir 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
If BaseSht Is Nothing Then Set BaseSht = ActiveSheet
Dim shapeNm As String: shapeNm = Application.Caller
BaseSht.Shapes(shapeNm).Visible = False 'ボタンを非表示にして押し込む動作をつける
Call initialize
'ダイアログを表示させて、開くを押したときだけ処理する
If folderSelect Then
Call fileSorting
If BlnErrFlg Then
MsgBox WMsg1
Else
MsgBox Msg1
End If
End If
BaseSht.Shapes(shapeNm).Visible = True '押し込んだボタンを戻す
Exit Sub
err:
MsgBox EMsg1
BaseSht.Shapes(shapeNm).Visible = True '押し込んだボタンを戻す
End Sub
'-------------------------------------
'色の変更、初期化等を行う
'-------------------------------------
Sub initialize()
Dim iRow As Long
'表の最終行番号を取得する
iRow = BaseSht.Cells(START_DATA_ROW, START_DATA_COL_NUM).SpecialCells(xlCellTypeLastCell).row
'表全体の文字色を黒色に変更する
Range(BaseSht.Cells(START_DATA_ROW, START_DATA_COL_NUM), BaseSht.Cells(iRow, END_DATA_COL_NUM)).Font.ColorIndex = 1
'振り分け先パスに値が入ってない場合は、ツールと同階層のパスを設定する
If BaseSht.Range(DISTRIBUTE_PATH_POINT).Value = "" Then
ExportDir = ThisWorkbook.Path
Else
ExportDir = BaseSht.Range(DISTRIBUTE_PATH_POINT).Value
End If
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
'ファイル/フォルダが入っている列番号
colFile = col * 2 + 1
folderNm = Cells(row, colFolder)
fileNm = Cells(row, colFile)
'格納先フォルダ、またはファイル/フォルダに値が入っている場合、フォルダーパスを取得する
If folderNm <> "" Or fileNm <> "" Then
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
End If
'指定された格納先フォルダが存在しない場合はエラーとする
If Dir(ExportDir & 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(ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder) Or _
fso.folderExists(ExportDir & 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(ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder, True)
Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder
Else
Call fso.CopyFolder(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
Destination:=ExportDir & 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(ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder, True)
Name ImportDir & PATH_DELIMITER & tgtFileOrFolder As _
ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder
Else
Call fso.CopyFile(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
Destination:=ExportDir & 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 _
ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder
Else
Call fso.CopyFolder(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
Destination:=ExportDir & 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 _
ExportDir & folderPath & PATH_DELIMITER & tgtFileOrFolder
Else
Call fso.CopyFile(Source:=ImportDir & PATH_DELIMITER & tgtFileOrFolder, _
Destination:=ExportDir & folderPath & PATH_DELIMITER)
End If
End If
End If
tgtFileOrFolder = Dir()
Loop
End If
Next col
Next row
End Sub
'===========================================
'当ファイルのエクセル内の値を変更した後に実行する処理
'===========================================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If BaseSht Is Nothing Then Set BaseSht = ActiveSheet
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 BaseSht.Cells(iRow, (2 * i) + 1).Value <> "" Or BaseSht.Cells(iRow, 2 * i).Value <> "" Then
BaseSht.Range(Cells(iRow, (2 * i) + 1), Cells(iRow, 2 * i)).Interior.Color = RGB(255, 255, 255)
existFlg = True
Else
BaseSht.Range(Cells(iRow, (2 * i) + 1), Cells(iRow, 2 * i)).Interior.Color = RGB(220, 220, 220)
End If
Next
If existFlg = False Then
BaseSht.Range(Cells(iRow, START_DATA_COL_NUM), Cells(iRow, END_DATA_COL_NUM)).Interior.Color = RGB(255, 255, 255)
End If
existFlg = False
Next
End If
End Sub
'==========================================================
'出力先フォルダを選択するセルをダブルクリックした際に実行される処理
'==========================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If BaseSht Is Nothing Then Set BaseSht = ActiveSheet
Dim tmp As String
tmp = BaseSht.Cells(Target.row, Target.Column).Address(ColumnAbsolute:=False, RowAbsolute:=False)
If tmp <> DISTRIBUTE_PATH_POINT Then
Exit Sub
End If
'フォルダ選択ダイアログを表示させる
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Msg3
If .Show <> 0 Then
BaseSht.Range(DISTRIBUTE_PATH_POINT).Value = .SelectedItems(1)
Else
End
End If
End With
End Sub
＜手順５＞
マクロを含んだExcelとして、ファイルを保存します。
- 左上にある「保存」アイコンをクリックします。
- 「ファイルの種類」から「Excelマクロ有効ブック」を選択します。
- 「保存」をクリックします。
＜手順６＞
「ファイル振り分け実行」ボタンにメイン処理「ファイル振り分け実行_Click」のマクロを設定します。
- 「ファイル振り分け実行」ボタンを右クリックします。
- 「マクロの登録」をクリックします。
- 「Thisworkbook.ファイル振り分け実行_Click」を選択します。
- 「OK」をクリックします。
※「ファイル振り分け実行」にカーソルを当てて、指の形になっているのを確認します。
これで事前準備は完了です。
あとは「当ツールの使用方法」で記載された方法でツールを実行できます。
なお、当マクロの開発環境は、OS：Windows10 、Excelソフトウェア：Microsoft Office 365となっており、当環境では動作確認ができていますが、他の環境で正常に動作するかは確認できていません。
正常に動作しない場合は、コメントいただければ幸いです。
また以下にて、このような業務効率化できるツールを機能ごとの一覧でまとめてますので、ご興味のある方はご覧ください。
自力で業務効率化できるツール等を作成する場合は、「オンラインITスクール」を利用するとモチベーションを保ちつつ、効率的に学習とアウトプットができると思います。
上記の「侍テラコヤ」は月額2,980円～ という日本最安級の料金でプログラミング学習ができ、今なら初めての方でも安心できる「１か月全額返金保証」があります。
自分に合わないと感じた場合は返金してもらえるため、ノーリスクで試すことができます。是非一度体験してみることをオススメします ^ ^
ツールのダウンロードはこちら
下記よりExcelファイルをダウンロードして、記事の途中にありました VBAのソースコードをツール内に組み込んで使用してください。
【Excel VBA】ファイル自動振り分けツール
※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています
他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います。
＜このツールが『結構使える！』と思ったら、下のグッドボタンを押していただけたら幸いです＞
こんにちは。
ファイル自動振り分けのマクロを活用させていただいております。
一つ質問をさせて下さい。
フォルダ1→フォルダ2→フォルダ3というフォルダ1の中に2階層のフォルダが有り、フォルダ2にファイルA、フォルダ3にファイルBを振分けようとしましたが、うまく行きませんでした。
フォルダ1にファイルA、フォルダ2にファイルBの振分けは出来ましたので、第1階層のフォルダには必ずファイルを割り当てないと振り分けは出来ないのでしょうか？
第1階層のフォルダに振り分けずにその中のサブフォルダにファイルを振分けしたいと思っております。
お手数ですが、振分け方法をご教授いただければと思います。
宜しくお願い致します。
管理人のRHです。
当ツールをお使い頂き、また併せて問題をご報告いただき、ありがとうございます。
確かにおっしゃる通り、第1階層のフォルダには必ずファイルを割り当てないと振り分けができない仕様となっております。恐れ入ります、気が付きませんでした。
目的を達成するための別の案として、以下の状態で実行してみるとうまくいきますでしょうか。
１．この自動振り分けマクロのファイルを「フォルダ2」と同階層に配置する。
２．A2セルには「フォルダ2」を記入し、C列に「フォルダ3」を記入する。
※ファイルAはB列、ファイルBはD列となります。
返信ありがとうございます。
説明不足で申し訳ございませんが、以下の使い方を想定しているのでご提案いただいた方法だとちょっと難しいと思います。
・フォルダ1→フォルダ2→フォルダ3のフォルダ2にファイルA、フォルダ3にファイルBを振り分けるというのがフォルダ違いで100パターン程有り、それを同時に処理したいと考えています。
・フォルダ1にファイルを振り分ける事も有るが、フォルダ1には振り分けずその中のサブフォルダのみにファイルを振り分ける使い方も有る
試しにA2セルにフォルダ1、B2セルにダミーのファイル名、C3にフォルダ2、D3にファイルA、E4にフォルダ3、F4にファイルBを入れて実行するとB2セルは当然赤字でエラーになりましたが、フォルダ2、3にファイルの振分けをする事が出来ました。
このやり方で使おうと思いますが、他に良い方法があれば教えていただけないでしょうか？
お手数をお掛けしますが、宜しくお願い致します。
管理人のRHです。
そうでしたか、誤った解釈しておりました申し訳ありませんでした。
このツールの現状の作りでは、茶々様の言う通りB2にダミーファイル（存在しないファイル）を設定して動かすとそこをスキップして動作するので、ひとまずその方法での使用をお願いします。
そのような使い方があったとは考えが足りなかったです。B2にファイル指定がない場合でも動くように修正致します。
コメント、ありがとうございます。
他の質問もありますので新たにコメントさせていただきます
はじめまして。
ファイルの自動振り分けの検索でこちらにたどり着きました。
大変参考になります。
使用してみてエラーというかうまくできない箇所がありましたのでご質問いたします。
ファイル名で文字数の制限か、規則の制限はありますでしょうか？
例えば、
①a_【asdko1010_10】【見積書】_相手先様_自分の名前
上記のようなファイル名の場合、”【見積書】”の箇所までのファイル名は振り分けをしてくれるのですが、フルのファイル名だと振り分けのエラーがでてしまいます。
すみかっこが原因なのか文字数の問題なのかなにか対策ありましたら教えていただけますと幸いです。
(ファイルの文字数をカウントしたところ59文字前後になりました。)
何度も申し訳ございません。
先ほど質問させていただいたものです。
ファイル名は何個試行錯誤してわかったのですが、
どうやらファイル名のカタカナの濁音に問題があったようです。
“ジ”が、シと゛に分かれていたのがエラーを起こしてしまう問題のようです。
カタカナ部分を書き換えたところ無事読込できました。
お手数おかけして申し訳ありません。
ありがとうございました。
管理人のRHです。
当ツールをお使い頂き、ありがとうございます。
ぽぽぽん様、無事マクロを実行できたということで安心しました、また何かありましたらコメントをお願いします。
度々のコメントで申し訳ございません。
本ツールではフォルダの振分けは出来ないと思いますが、コードを一部変更してフォルダの振分けをする事は可能でしょうか？
対応可能な場合、変更内容をご教授いただければと思います。
マクロ、VBAの知識が無い為、大まかな質問になり申し訳ございませんが、宜しくお願い致します。
管理人のRHです。
ご質問頂き、ありがとうございます。ご返答が遅くなりました。
暫定的な対策として、フォルダを振り分けることも可能です。
その場合は、136行目の「fileNm = Dir(ImportDir & “\” & fileNm & “.*”)」をコメントアウト（先頭に [‘] シングルコーテーションを付ける）していただければひとまずは正常にフォルダを振り分けることができます。
しかし、136行目をコメントアウトした場合、通常の使い方であるファイルの振り分けを行うことができませんので、ご注意ください。
＞本ツールではフォルダの振分けは出来ないと思いますが、コードを一部変更してフォルダの振分けをする事は可能でしょうか？
＞対応可能な場合、変更内容をご教授いただければと思います。
後日、改めてファイルとフォルダの両方を振り分け可能なコードを記載したいと思います。
回答ありがとうございます。
教えていただいた暫定対策で無事フォルダの振分けが出来ました。
多くのフォルダを扱うので、本当に助かりました。
管理人のRHです。
いえ、無事目的が達成されたとのことでよかったです。
また何か作業効率化において必要な機能等がありましたら、ファイル自動振り分けツールとは関係ないものでも良いので、ご要望いただければと思います。
こんにちは。
ファイル自動振り分けのマクロについてまた質問をさせていただきます。
フォルダ名によってはこのマクロに対応が出来ないという事はありますか？
フォルダ名が赤くなるエラーが発生し、見直してもフォルダ名は間違っておらず、コピー貼り付けでフォルダ名を再度入れ直してもやはりエラーになってしまいます。
フォルダ名とファイル名は以下の通りになります。
・行2 フォルダ1：営業所別 ファイル1：1
・行3 フォルダ2：東京_6243 ファイル2：6243_東京
・行4 フォルダ1：営業所別 ファイル1：2
・行5 フォルダ2：南東京_6246 ファイル2：6246_南東京
以前よりこのマクロを使用しており、別のパターンで使用しようと試した所、エラーが発生しました。
お手数ですが、アドバイスをいただければと思います。
宜しくお願い致します。
管理人のRHです。
返信が遅くなり、申し訳ありません。
ファイルを振り分けるために動作させたかと思いますが、おっしゃっていただいた以下のフォルダ構成とファイルを用意し、当マクロを実行させた場合は、私が使っている環境ですと正常に動作し、振り分けが完了しました。
＞・行2 フォルダ1：営業所別 ファイル1：1
＞・行3 フォルダ2：東京_6243 ファイル2：6243_東京
＞・行4 フォルダ1：営業所別 ファイル1：2
＞・行5 フォルダ2：南東京_6246 ファイル2：6246_南東京
フォルダ名が赤くなるということは、通常考えられるのは指定したフォルダが存在していない、または指定した階層にフォルダが存在していない可能性が高そうです。
コピー貼り付けでフォルダ名を指定頂いたとのことなので、もしかするとフォルダが存在する階層が原因かもしれません。今一度ご確認いただけますでしょうか。
そして、まだ正常に動作しないようなら、可能なら茶々様のexcelのバージョンなどを教えていただいてよいでしょうか。
こちらこそ返信が大変遅くなり、申し訳ございませんでした。
具体的な原因は分かりませんが、PCを変えて試した所、問題なく処理出来ました。
ご確認いただき、ありがとうございました。
すみません、間違って違うとこにコメント載せちゃってたので再記しますm(_ _)m
はじめまして、こちらのツール大変便利に活用させていただいています。
vba独学初心者なのですが、操作の手間を削減するためにﾀﾞｲｱﾛｸﾞからのﾌｫﾙﾀﾞを指定せず、振り分けファイルのパスを直接指定してみたのですが上手くいきません
ﾌｫﾙﾀﾞｾﾚｸﾄの構文を消して
Dim ImportDir As String
ImportDir = ﾌｫﾙﾀﾞﾊﾟｽ
ではダメでしょうか？何か手だてがあればご教示いただきたいです
管理人のRHです。
かきさん、ツールを使用いただき、またコメント頂きありがとうございます。
ダイアログを表示させずに、振り分けるファイルを固定のフォルダで処理する場合は、かきさんのおっしゃる箇所（85～96行目の部分）を修正することで合っています！
しかし修正する内容としては、以下になります。
①「ﾌｫﾙﾀﾞｾﾚｸﾄの構文を消して」 →記載OK
②「Dim ImportDir As String」 →不要
③「ImportDir = ﾌｫﾙﾀﾞﾊﾟｽ」 →記載OK
“ImportDir” は20行目で既に宣言しているので、改めての宣言は不要となります。
（※この記載があると二重定義になってしまうため）
そのため②「Dim ImportDir As String」は書かずに、①部分をコメントまたは記載を消していただき、③を追加で記載いただけたら動作すると思います。
思うように動作しない場合は改めてコメントいただけたらと思います。
できました！！
とても助かりましたし勉強になりました！！
返答も早く頂きましてありがとうございました
はじめまして。
ファイルの自動振り分けができないかネットを彷徨っていた所、こちらを発見し、求めていたモノだと感激し、使わして頂こうかと考えています。
VBAは初心者なのですが、
ファイル名に抽象性を持たせる為にはどうしたら良いでしょうか？または可能でしょうか？
例えば、ファイル名に◯◯を含む場合、このフォルダに移動という挙動にしたいのです。
ファイル名は、
日付(20220919)＋ユーザー名＋種類(「見積り」や「案内」など).拡張子
で考えています。
◯◯は基本的にユーザー名(会社名)となります。
ユーザー毎にフォルダを一つ割り振っています。
宜しくお願いします。
管理人のRHです。
かいさん、ツールを使用いただき、またコメント頂きありがとうございます。
ファイルに抽象性を持たせる場合は、例えばアスタリスクを用いてワイルドカードを使用させる等の動作になると思います。
しかし、申し訳ありませんが、現時点ではツールは対応していません。
>ファイル名に抽象性を持たせる為にはどうしたら良いでしょうか？または可能でしょうか？
抽象的なファイル名等の指定にしても動作するように改修いたしますので、少々お待ちいただいて良いでしょうか。
RH様
返信ありがとうございます！
対応できないのですね。
自分でも勉強しつつ、
改修心待ちにしております！
管理人のRHです。
かいさん、コメント頂きありがとうございます。
お待たせいたしました。ファイルに抽象性を持たせて指定した際に動作するよう9月19日に改修いたしました。
例えば、
「20220919_user1_見積り.xlsx」の命名ルールのファイルがあった場合に「ファイル/フォルダ」の項目に「*_user1_*.xlsx」と入力すれば、ユーザー毎に作られたフォルダにファイルを振り分けることができるかと思います。
思うように動作しない場合は改めてコメントいただければと思います。
はじめまして。ファイルをフォルダに振り分けるVBAができないかと思い探していたところこちらにたどり着きました。まさに自分のやりたかったことと近く、感激しております。
もしよろしければご教示いただきたいのですが、
ファイル名が【取引先名_発注ナンバー_日付.xlsx】の発注書を毎日大量に作成しているため、ワイルドカードを使用して、作成済みの発注書を取引先名フォルダに自動振り分けするようにしたいと考えているのですが、振り分けるファイル名を＊取引先＊.xlsxで指定した場合、振り分け先に同じ名称のファイルがあるということでエラーになってしまうのですが何か方法はないでしょうか？
A社_0001_0928
A社_0002_0929
A社_0003_1001
→A社フォルダに随時蓄積
よろしくお願いいたします。
管理人のRHです。
めかぶさん、ツールの使用とコメントありがとうございます。
現象について、もう少し詳しくお聞きしたいのですが、
当方の環境で以下のファイルを作成して、「*A社*.xlsx」でファイル振り分け処理を行ってみたところ、正常に振り分けが完了しましたが、めかぶさんが行った操作と違ってますでしょうか？
・A社_0001_0928.xlsx
・A社_0002_0929.xlsx
・A社_0003_1001.xlsx
また、質問の意図としては、既に存在するファイルも含めて割り振りたいということをご希望でしょうか。
例）既にファイルがある場合は上書き保存する。（or 当該ファイルはスキップして他のファイルは振り分けるようにする）
RH様
ご確認ありがとうございます。
わかりにくくて申し訳ありません。
下記のような流れで活用できればと思っております。
・9/29
当日作成したファイルを「振り分け用」フォルダに入れ、各メーカー名のフォルダに振り分け（「振り分け用」フォルダのファイルは全削除）
・9/30
当日作成したファイルを「振り分け用」フォルダに入れ、各メーカー名のフォルダに振り分け（「振り分け用」フォルダのファイルは全削除）
上記要領で各メーカー名のフォルダにどんどんファイルを蓄積していく…
（ファイル名はA社_XXXX_MMDD.xlsでメーカー名のみ不変）
一度に振り分けを行う場合、処理できるのですが、
「A社_0001_0928」を「A社」フォルダに移動した後、「A社_0002_0929」を「A社」フォルダに移動しようとするとエラーになる状態です。（振り分け元のフォルダには「A社_0002_0929」のみ、振り分け先のフォルダには「A社_0001_0928」が入っている状態）
管理人のRHです。
めかぶさん、コメントありがとうございます。
すいません、そういうことですね。理解致しました。
二回に分けて同格納フォルダに振り分け実行した場合に、うまく動作しないとお見受けしました。わたしの環境でも同様の操作をしてみたところエラーメッセージが表示され正常に動作しませんでした。申し訳ありません、ツールの不具合でした。
本日（2022年9月30日付）、複数回に分けて同様の格納先フォルダにワイルドカードを使用して実行させても動作するよう不具合を修正しましたので、改めてご使用いただけますと幸いです。（※全体のUIも少し変更しましたのでご了承ください。）
思うように動作しない場合は改めてコメントいただければと思います。
RH様
ご対応ありがとうございます。
試してみたところ、希望していた通りの処理ができました！
時間がかかっていた作業を効率化できそうです。
本当にありがとうございます。
管理人のRHです。
めかぶさん、コメントありがとうございます。
業務の効率化ができるようになったようで、大変喜ばしく思います。
また他のツールも是非ご使用いただけたら幸いです。
はじめまして。
ファイルをフォルダに自動で振り分ける事ができないかと思い探していたところ、このHPにたどり着きました。
短納期で大量のファイルデータをフォルダに格納しなければならないので感激しております。
しかしながらVBAって何だろう？という知識しかないため下記についてご教示頂けないでしょうか。
データの保管場所がクラウド上での作業となります。
格納フォルダと振り分けしたいファイルは同じフォルダ内にないと処理はできないのでしょうか。
管理人のRHです。
ぽぽぽんさん、コメントありがとうございます。
現状は、振り分けたいファイルはボタンを押した時に振り分けるファイルが存在するフォルダを選択できるので、ツールと同フォルダになくても問題ありませんが、格納先フォルダはツールと同じフォルダ内に存在していないと動作しません。
データの保管場所がクラウド上にある環境のため、格納先フォルダとツールが同じフォルダ内になくても動作させたいというご要望で合ってますでしょうか。
もしその認識が合っておりましたらツールを改修いたします。
管理人のRHです。
ぽぽぽんさんから頂いたコメントより、ツールの使い勝手の面から、格納先フォルダがツールと同階層でなくても動作した方が良い（保存場所を指定する）と考えましたので、12/5にツールを改修しました。
はじめまして、こんにちは。
記事拝見させていただきました。
当方、パソコンの初心です。
現在、大量のPDFファイルを所定のフォルダに振り分けする方法を模索しております。
約20万枚のPDFファイルを、3万のフォルダに分類して振り分けしたいのですが、RH様の提供されているツールで可能でしょうか？
詳細を説明しますと、PDFファイル名は「12桁の半角数字_一桁の半角数字」の半角文字14個です。
最後の半角数字は1～9までの9通りあり、最初の12桁は3万通りあります。
フォルダー名は、「12桁の半角数字_氏-名」で3万フォルダあります。
例になりますが、
PDFファイル［000000001234_1］［000000009876_5］を、最初の12桁の半角数字が同じ
フォルダー【000000001234_山田-太郎】【000000009876_山田-花子】にそれぞれ降り分ける事が可能でしょうか？
説明が下手で申し訳ございませんが、ご教示いただけますでしょうか。
よろしくお願いします。
管理人のRHです。
すけぽんさん、コメントありがとうございます。返答が大変遅くなり申し訳ありません。
お問い合わせ頂いた内容は、大きく以下２つの観点があるかと思います。
１．ファイル名の先頭12桁の半角数字が同じであるフォルダ内に振り分けられるか。
２．20万ファイルを３万フォルダに振り分けられるか。
１に関しては、ファイル名にはワイルドカードが使用できますので、フォルダ名「000000001234_山田-太郎」、ファイル名「000000001234*」と入力すれば動作すると思います。
※フォルダ名が一意に特定できれば動作しますが、振り分けるフォルダ名のアンダーバー以降が複数存在しておりワイルドカード（*）を使う必要がある場合は現状のツールでは動作しません。
２に関しては、実際３万ファイル分の動作確認ができておらず、使用するPCのスペック等の影響も受けるためすけぽんさんのPCで動作するかはなんとも言えません。
可能でしたら何度かに分けて実行させる等の対処で、ある程度はカバーできるかと思います。
[…] 当記事にはマクロの元になるExcelファイルがダウンロード可能で、VBAのコードも記事内に記載がありますので、Excel VBAやマクロが良く分からないという方でもすぐに使用できます。 […]
はじめまして。
以前使用していたソフトが不安定になってきた為、
検索していたところ、こちらにたどり着きました。
エクセルベースなので、条件を入れやすく、とても重宝しております。
同一名称ファイルが存在した場合に、ファイル名に文字を追加して（例えば日付）保存ということは可能でしょうか？
管理人のRHです。
HIROさん、コメントありがとうございます。返答が遅くなり大変申し訳ありません。
同一名称ファイルが存在した場合に、ファイル名に文字を追加して（例えば日付）保存ということは現ツールを改修すれば可能です。
その場合は、ツールの仕様として、同一名称ファイル等が存在した場合にファイル名を変えて保存できるように選択肢を増やして、改修しますので今しばらくお待ちいただけますようお願いします。
はじめまして。
ご質問ですが、自分のPCからファイル(PDF)をNAS(共有)に振り分けたいのですが、そのような事が可能でしょうか。
いろいろ試したのですが、うまくいきませんでした。
回答を宜しくお願い致します。
管理人のRHです。
KOZIさん、コメントありがとうございます。
NASに対して、ファイル振り分けができないということですね。
以下内容の少し細かい状況をお聞きしたいのですが、
①実施している環境の前提としては、NASには「\\192.168.XXX.XXX」というようなIPアドレスを用いて指定している状況でしょうか、それともネットワークドライブに割り当てて（例えばUドライブなど）指定している状況でしょうか。
②うまく動作しないのは、どこかでエラーが発生している状況でしょうか。それともマクロは実行できるが思った挙動をしないという状況でしょうか。
恐れ入りますが、ご確認いただけますと幸いです。
ＲＨさま
早急のご対応、大変感謝しております。
①ですが、ＩＰｱﾄﾞﾚｽを用いている状態です。
②ですが、実行すると「予期せぬエラーが発生しました、ツール利用ルールをもう一度実行してください。」とメッセージが表示されます。
ヴァージョンはv3-1です。
第一階層の格納先フォルダの一つ目の文字が赤くなっておりますので一つ目でエラーになっていると思われます。
EXCELの振り分け先パスは該当の「\\192.168.1.233」と入力しております。
もしかしたら、NASの権限は関係あったりしますでしょうか。PCより直接フォルダが見れる状態にはなっております。
大変申し訳ありませんが、よろしくお願い致します。
管理人のRHです。
KOZIさん、コメントありがとうございます。
当方の環境ではNAS等に見立ててIPアドレスを指定して実施してみたところ正常に動作しました。
KOZIさんのおっしゃるとおり、NASへのアクセス権限（書き込み可能か等）が影響している可能性があります。他にもPC内のセキュリティ対策ソフトがプログラムの実行を拒否していることもあるようです。
既にご確認済みかとは思いますが、第一階層の格納先フォルダは存在していて、NAS側も読み書き可能な権限が付与されている状態で合っておりますでしょうか。
また可能でしたら、ソースコードの以下を書き換えて実行いただくことは可能でしょうか。
①63行目をコメントにする（行の最初に ‘ を追加する）
②64行目に以下を追加する。
Dim tempEMsg As String: tempEMsg = EMsg1 & vbCrLf & _
“エラー番号：” & err.Number & “ エラー内容：” & err.Description
MsgBox tempEMsg
上記をしていただくとエラー内容がある程度分かりますので、エラー発生箇所を概ね判断することができます。
お手数おかけしますが、宜しくお願いします。
RHさん
いつも早急のご対応、ありがとうございます。
試してみましたが、エラー内容は以下の通りとなります。
・・エラー番号：52 エラー内容：ファイル名または番号が不正です。・・
上部の振り分け先パスをダブルクリックして第一階層の最初のところを表示されております。
何度も大変申し訳ありませんが、よろしくお願い致します。
管理人のRHです。
KOZIさん、確認とコメントありがとうございます。
（※返信数の上限を超えたので、新規でコメントします。）
エラー番号：52の場合は、以下の原因等が考えられます。
①NASのパスである「\\192.168.XXX.XXX」が原因で、Excelで指定している「振り分け先パス」へアクセスできない。
（解決方法）
「\\192.168.1.233」をネットワークドライブに割り当てて、割り当てたパスを「振り分け先パス」に指定する。
②NASのパス「\\192.168.XXX.XXX」の後に漢字や認識出来ない文字が使われている、またはフォルダパスが長すぎる可能性がある。
（解決方法）
該当するファイルが保存してあるフォルダパスに漢字が使われている場合は、漢字を英語に一時的に変換してみる。そしてフォルダパスが長すぎる場合は半角256文字以内になるようフォルダ保存場所を変更してみる。
お手数かけますが可能でしたら、上記のそれぞれ（解決方法）を実施してみて、今一度ツールの実行をお願いします。
ＲＨさま
早急のご対応、いつもありがとうございました。
いろいろ試してみた結果、成功しました。
前回の回答で頂いた事を試しましたが良い結果が得られず、いろいろ試行錯誤して試した結果、ひとつフォルダを間に追加して振り分け先パスに「\\192.168.XXX.XXX\フォルダー名」のようにフォルダーをひとつかませたら成功しました。
なぜフォルダーを追加したら出来たのかは不明です。
今後快適に作業が進みそうなので非常に感謝しております。
ありがとうございました。
ＲＨさま
前回は、いろいろとお世話になりました。
ひとつご相談ですが、ファイル振分け実行の際に振り分けるファイルが入っているフォルダを選択(指定)しますが、こちらも振り分け先パス同様画面で表示して指定できないでしょうか。
宜しくお願い致します。
管理人のRHです。
KOZIさん、対応とコメントありがとうございます。
IPアドレスの後にフォルダ名を入れることで動作したということで原因は分かりませんが、無事動作したということで承知しました。
また振り分けるファイルが入ったパスを画面に表示させることはできます。
ご対応いたしますので、少々お待ちください。