VBAで拡張子別にフォルダへ振り分け保存する方法｜InStrRev・Select Case・MkDir・FileCopyの使い方 - Excelのムダを省くJIMOVE

VBAでファイルを拡張子別のフォルダに自動振り分けするには、InStrRev と Right で拡張子を取得し、Select Case で保存先を切り替えるだけです。xlsx・xlsm・pdfなど種類が混在しがちな業務フォルダを、自動で整理された状態に保てます。

この記事では、次の内容を順番に解説します。

ファイル名から拡張子を取得する方法
拡張子ごとにフォルダを振り分けて保存するコード
フォルダが存在しない場合に自動作成する処理
フォルダ内のファイルを一括振り分けする応用パターン

ファイル名から拡張子を取得するには？

InStrRev でファイル名の最後の「.」の位置を見つけ、Right でその後ろの文字を取り出します。LCase で小文字に統一しておくと、大文字・小文字の違いによる判定ミスを防げます。

Sub GetExtension()

    Dim fName As String
    Dim fExt  As String

    fName = ThisWorkbook.Name        '例：売上表.xlsm
    fExt  = LCase(Right(fName, Len(fName) - InStrRev(fName, ".")))

    MsgBox "拡張子：" & fExt        '→ xlsm と表示される

End Sub

FSOを使う方法もシンプルです。

'FileSystemObjectで取得する方法
Dim fso  As Object
Dim fExt As String
Set fso  = CreateObject("Scripting.FileSystemObject")
fExt     = LCase(fso.GetExtensionName("売上表.xlsm"))   '→ xlsm

拡張子ごとにフォルダを振り分けて保存するには？

Select Case で拡張子ごとの保存先フォルダを決め、SaveCopyAs でコピーを作成します。元のファイルはそのまま残り、振り分け先にコピーが保存されます。

Sub SaveByExtension()

    Dim fName   As String
    Dim fExt    As String
    Dim saveDir As String

    fName = ThisWorkbook.Name
    fExt  = LCase(Right(fName, Len(fName) - InStrRev(fName, ".")))

    'フォルダを振り分ける
    Select Case fExt
        Case "xlsx"
            saveDir = ThisWorkbook.Path & "¥xlsx¥"
        Case "xlsm"
            saveDir = ThisWorkbook.Path & "¥xlsm¥"
        Case "pdf"
            saveDir = ThisWorkbook.Path & "¥pdf¥"
        Case Else
            MsgBox "未対応の拡張子です：" & fExt, vbExclamation
            Exit Sub
    End Select

    'フォルダが存在しなければ作成
    If Dir(saveDir, vbDirectory) = "" Then MkDir saveDir

    '元ファイルを振り分け先にコピー保存
    ThisWorkbook.SaveCopyAs saveDir & fName

    MsgBox "保存完了：" & vbCrLf & saveDir & fName

End Sub

フォルダ内のファイルを一括で振り分けるには？

対象フォルダ内にある複数のファイルを、拡張子別のサブフォルダに一括で移動させる例です。FileCopy でコピーしてから Kill で元ファイルを削除することで「移動」を実現します。

Sub SortFilesByExtension()

    Dim fso       As Object
    Dim folder    As Object
    Dim file      As Object
    Dim srcPath   As String
    Dim destDir   As String
    Dim fExt      As String
    Dim movedCount As Long

    'ダイアログでフォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show <> -1 Then Exit Sub
        srcPath = .SelectedItems(1) & "¥"
    End With

    Set fso    = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(srcPath)

    movedCount = 0

    For Each file In folder.Files
        fExt    = LCase(fso.GetExtensionName(file.Name))
        destDir = srcPath & fExt & "¥"

        'サブフォルダが存在しなければ作成
        If Dir(destDir, vbDirectory) = "" Then MkDir destDir

        'ファイルをコピーして元を削除（移動）
        FileCopy file.Path, destDir & file.Name
        Kill file.Path
        movedCount = movedCount + 1
    Next file

    MsgBox movedCount & " 件のファイルを拡張子別フォルダに移動しました。"

End Sub

まとめ

拡張子の取得は Right(fName, Len(fName) - InStrRev(fName, ".")) か FSOの GetExtensionName で行う
LCase で小文字に統一すると大文字・小文字の違いによる判定ミスを防げる
Select Case で拡張子ごとの保存先を切り替えると、条件が増えても読みやすい
保存先フォルダがない場合は Dir + MkDir で自動作成する
一括振り分けは FileCopy + Kill の組み合わせで「移動」を実現できる

よくある質問

SaveCopyAsとFileCopyの違いは何ですか？

SaveCopyAs はExcelのブックオブジェクトに対して使うメソッドで、現在開いているブックのコピーを指定パスに保存します。FileCopy はVBAの命令で、任意のファイルを別の場所にコピーします。開いていないファイルを移動したい場合は FileCopy を使います。

Killでファイルを削除するのは怖いです。元に戻せますか？

Kill で削除したファイルはゴミ箱に入らず完全に削除されます。事前にコピーが正常にできたか確認してから削除するか、削除前にバックアップフォルダにコピーを残す処理を加えておくと安心です。

同名のファイルが振り分け先にすでにある場合はどうなりますか？

FileCopy は上書きされます。上書きを防ぎたい場合は、コピー前に Dir(destDir & file.Name) でファイルの存在を確認し、ある場合はファイル名に日時を付けて保存する処理を加えてください。

振り分けの対象から特定のファイルを除外したいです

ループ内に If file.Name = "除外するファイル名.xlsx" Then GoTo NextFile のようなスキップ処理を追加します。または名前に特定のキーワードが含まれるもの（InStr(file.Name, "_draft") > 0 など）を除外する条件を入れる方法もあります。

PDFファイルはExcelから直接振り分けできますか？

できます。PDFはExcelブックではありませんが、VBAの FileCopy や FileSystemObjectの CopyFile を使えばExcelファイルと同じように移動・コピーができます。ただし SaveCopyAs はExcelブック専用なので、PDFには使えません。

動画で学びたい方へ

「記事を読んでも、実際に自分で書けるか不安…」という方には、動画で基礎からじっくり学べる講座がおすすめです。

VBAが初めての方を前提に、つまずきやすいポイントを先回りして解説しています。サンプル動画は無料でご覧いただけます。