【VBA】フォルダを自動作成してファイルを振り分ける方法（コピペOK）

Q: フォルダが既に存在する場合はどうなる？

最小版では Dir() で存在チェックし、存在する場合はスキップする（MsgBoxで通知）。実務版でも fso.FolderExists で確認してから作成するので、既存フォルダは上書きされない。C列に「フォルダ既存（スキップ）」と記録される。

Q: ファイルを移動ではなくコピーで振り分けたい（元を残したい）

最小版では Name 文の行を FileCopy 文に変える。実務版では fso.MoveFile を fso.CopyFile に変更する。コピーの詳細は ファイルを別フォルダにコピー・移動する方法 を参照。

Q: ネットワークドライブ（\\server\share）でも使える？

一般的にはUNCパス（ \\サーバー名\共有名\ ）でも動作する。ただしアクセス権限が必要。共有フォルダのファイルを移動する場合は、他の利用者に事前確認すること。ネットワーク遅延で処理に時間がかかる場合がある。

VBA

2026.03.182026.04.27

完成イメージ（Before / After）
1. どんな場面で使う？
実行前の準備
手順（コピペ → 実行まで約10分）
コード（最小版）– MkDirでフォルダ1つ作成＋Nameでファイル1つ移動
1. 書き換えポイント
2. コードの流れ
コード（実務版）– セル一覧からフォルダ一括作成＋キーワード振り分け＋ログ
1. 書き換えポイント
2. コードの流れ
よくある落とし穴5選
FAQ
まとめ
1. 関連記事
次にやりたくなること

完成イメージ（Before / After）

Before（手動で振り分け）

	A（フォルダ名）	B（状態）
1	フォルダ	状態
2	2026-03（未作成）	ファイル90個が日付フォルダに散在
3	手動で作成＆移動	30分かかる、ミスが出る

After（VBAで自動振り分け）

	A（フォルダ名）	B（キーワード）	C（ログ）
1	フォルダ名	キーワード	ログ
2	2026-03	2026-03	検査データ_2026-03-01.csv → 移動成功
3	2026-04	2026-04	検査データ_2026-04-01.csv → 移動成功

フォルダ作成から振り分けまで10秒で完了。ログがC列に記録されるので結果も確認できる。

どんな場面で使う？

品質管理: 日付フォルダの検査データを月別フォルダにまとめ直す
経理: 請求書・領収書を取引先別・月別フォルダに自動仕分けする
営業: 顧客提出資料をプロジェクトフォルダに振り分ける
どんな職種でも: 「毎月フォルダを手動で作って、ファイルを1つずつ移動している」なら、この自動化が使える

—

実行前の準備

バックアップを取る（必須）

ファイル移動（Name文 / MoveFile）は、元フォルダからファイルがなくなる操作です。 間違ったフォルダに振り分けてしまうと、ファイルを探すのに手間がかかる。必ず元フォルダを丸ごとコピーしてバックアップを取ること。

手順：

エクスプローラーで元フォルダを右クリック
「コピー」→ 同じ場所に「貼り付け」
「作業フォルダ – コピー」というバックアップが作られる

Excelをマクロ有効ブック（.xlsm）で保存する

Excelを開く（新規でも既存でもOK）
「ファイル」→「名前を付けて保存」
ファイルの種類を 「Excel マクロ有効ブック (*.xlsm)」 に変更して保存

.xlsx のままだとマクロは保存できない。必ず .xlsm にすること。

Windowsの拡張子を表示する

ファイル名で振り分けるため、拡張子（.xlsx .csv など）が見えている必要がある。Windowsの初期設定では拡張子が非表示のため、以下の手順で表示する。

エクスプローラーを開く
上部メニューの「表示」タブをクリック
「ファイル名拡張子」にチェックを入れる

—

手順（コピペ → 実行まで約10分）

ステップ1：フォルダ名とキーワードを入力する（実務版の場合）

Sheet1 に以下のように入力する。

A1：フォルダ名（ヘッダー）
B1：キーワード（ヘッダー）
A2以降：作成したいフォルダ名
B2以降：振り分けに使うキーワード（ファイル名に含まれる文字列）

入力を楽にする方法: フォルダ名が決まっている場合は手入力でOK。元フォルダのファイル名を確認したい場合はフォルダ内のファイル一覧を自動出力する方法でA列にファイル名を出力すると、キーワードの検討がしやすい。

ステップ2：VBEを開いてコードを貼り付ける

Alt + F11 でVBE（コードを書く画面）を開く
メニュー「挿入」→「標準モジュール」
下の「コード（最小版）」または「コード（実務版）」をコピーしてコードウィンドウに貼り付ける

一般的にはAlt + F11で開けるが、企業のセキュリティ設定でVBAが無効化されている場合は、IT部門に確認すること。ボタンからワンクリックで実行したい場合はマクロをボタン1つで実行する方法を参照。

ステップ3：パスを書き換える

コード内の basePath（振り分け先の親フォルダ）と srcPath（元フォルダ）を、自分のフォルダパスに書き換える。

パスの末尾に \ を忘れないこと。

パスの確認方法：エクスプローラーでフォルダを開き、アドレスバーをクリックするとパスが表示される。それをコピーして使う。

ステップ4：マクロを実行する

Alt + F8 を押す
マクロ名を選択して「実行」
確認ダイアログが表示されるので内容を確認して「はい」を押す（実務版）

ステップ5：結果を確認する

振り分け先フォルダが正しく作成されているか確認する
ファイルが正しいフォルダに移動しているか確認する
C列のログに「振り分け先なし」のファイルがないか確認する（実務版）
振り分け先なしのファイルが元フォルダに残っているか確認する

—

コード（最小版）– MkDirでフォルダ1つ作成＋Nameでファイル1つ移動

まずはこれだけで動く。VBA標準の MkDir でフォルダを1つ作成し、Name 文でファイルを1つ移動する。参照設定は不要。


'============================================================
' ■ フォルダを1つ作成してファイルを1つ移動（最小版）
'   → MkDir でフォルダ作成
'   → Name 文でファイル移動
'   → 参照設定不要。VBA標準関数のみ
'============================================================
Sub CreateFolderAndMoveFile()

    '--- ★書き換えポイント ---
    Dim basePath As String
    basePath = "C:\Users\（ユーザー名）\Desktop\振り分け先\"  '← 振り分け先の親フォルダ

    Dim folderName As String
    folderName = "売上報告"                                   '← 作成するフォルダ名

    Dim srcPath As String
    srcPath = "C:\Users\（ユーザー名）\Desktop\作業フォルダ\" '← 元フォルダ

    Dim fileName As String
    fileName = "売上_202601.xlsx"                             '← 移動するファイル名
    '--- ★ここまで ---

    '--- フォルダの存在チェック → なければ作成
    If Dir(basePath & folderName, vbDirectory) = "" Then
        MkDir basePath & folderName
        MsgBox "フォルダを作成しました：" & basePath & folderName, vbInformation
    Else
        MsgBox "フォルダは既に存在します：" & basePath & folderName, vbInformation
    End If

    '--- 元ファイルの存在チェック
    If Dir(srcPath & fileName) = "" Then
        MsgBox "ファイルが見つかりません：" & srcPath & fileName, vbExclamation
        Exit Sub
    End If

    '--- 移動先に同名ファイルがないかチェック
    If Dir(basePath & folderName & "\" & fileName) <> "" Then
        MsgBox "移動先に同名ファイルが既に存在します：" & _
               basePath & folderName & "\" & fileName, vbExclamation
        Exit Sub
    End If

    '--- ファイルを移動（Name 旧パス As 新パス）
    Name srcPath & fileName As basePath & folderName & "\" & fileName

    MsgBox "ファイルを移動しました：" & vbCrLf & _
           srcPath & fileName & vbCrLf & _
           "→ " & basePath & folderName & "\" & fileName, vbInformation

End Sub

書き換えポイント

変数	説明	初期値
`basePath`	振り分け先の親フォルダ（末尾に `\`）	`"C:\Users\（ユーザー名）\Desktop\振り分け先\"`
`folderName`	作成するフォルダ名	`"売上報告"`
`srcPath`	元ファイルがあるフォルダ（末尾に `\`）	`"C:\Users\（ユーザー名）\Desktop\作業フォルダ\"`
`fileName`	移動するファイル名（拡張子を含む）	`"売上_202601.xlsx"`

コードの流れ

Dir() でフォルダ存在確認: Dir(パス, vbDirectory) が空文字なら存在しない → MkDir で作成
Dir() で元ファイル存在確認: ファイルがなければエラーメッセージを出して終了
Dir() で移動先の同名チェック: 移動先に同じ名前のファイルがあれば警告して終了
Name 文でファイル移動: Name 旧パス As 新パス で元フォルダから振り分け先フォルダにファイルを移動

ポイント:

MkDir はVBA標準の関数。参照設定は不要でそのままコピペで動く
MkDir で既に存在するフォルダと同名のフォルダを作ると 実行時エラー ’75’ になる。必ず Dir() で存在チェックしてから作成する
Name 文で移動すると、元フォルダからファイルがなくなる。コピーして残したい場合は Name の行を FileCopy srcPath & fileName, basePath & folderName & "\" & fileName に変える。コピーの詳細はファイルを別フォルダにコピー・移動する方法を参照
移動ではなくコピーで振り分けたい場合の詳細はファイルを別フォルダにコピー・移動する方法を参照

—

コード（実務版）– セル一覧からフォルダ一括作成＋キーワード振り分け＋ログ

複数のフォルダを一括作成し、ファイル名のキーワードで自動振り分けする場合はこちら。Sheet1のA列（フォルダ名）、B列（キーワード）に従って処理し、C列にログを記録する。

最小版でフォルダ作成とファイル移動の基本が分かったら、実務版でセル一覧からの一括処理に進もう。キーワード振り分けの仕組みが分かると、毎月の定型作業がボタン1つで完了するようになる。

以前、手動で月別フォルダを12個作り、100個のファイルを1つずつ振り分けていた。フォルダ名を打ち間違えて「2月」と「2月」（末尾に半角スペース）の2つができたり、違うフォルダにファイルを入れて気づかなかったりした。このコードを使い始めてからは、セルの一覧に打ち込んで実行するだけなので、打ち間違いもファイルの入れ間違いもゼロになった。


'============================================================
' ■ セル一覧からフォルダ一括作成＋キーワード振り分け＋ログ（実務版）
'   → Sheet1のA列:フォルダ名、B列:キーワード
'   → basePath配下にフォルダを一括作成
'   → srcPath内のファイル名にキーワードが含まれれば該当フォルダへ移動
'   → C列にログ記録
'   → 確認ダイアログ付き
'============================================================
Sub CreateFoldersAndSortFiles()

    '--- ★書き換えポイント ---
    Dim basePath As String
    basePath = "C:\Users\（ユーザー名）\Desktop\振り分け先\"  '← 振り分け先の親フォルダ

    Dim srcPath As String
    srcPath = "C:\Users\（ユーザー名）\Desktop\作業フォルダ\" '← 元フォルダ

    Dim wsName As String
    wsName = "Sheet1"                                         '← 設定シート名
    '--- ★ここまで ---

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(wsName)

    '--- 最終行を取得（A列基準）
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    If lastRow < 2 Then
        MsgBox "A列にフォルダ名が入力されていません。" & vbCrLf & _
               "A2以降にフォルダ名を入力してください。", vbExclamation
        Set fso = Nothing
        Exit Sub
    End If

    '--- 元フォルダの存在チェック
    If Not fso.FolderExists(srcPath) Then
        MsgBox "元フォルダが見つかりません：" & srcPath, vbExclamation
        Set fso = Nothing
        Exit Sub
    End If

    '--- 振り分け先の親フォルダの存在チェック
    If Not fso.FolderExists(basePath) Then
        MsgBox "振り分け先の親フォルダが見つかりません：" & basePath, vbExclamation
        Set fso = Nothing
        Exit Sub
    End If

    '--- 確認ダイアログ
    Dim msg As String
    msg = "以下の設定でフォルダ作成＋ファイル振り分けを実行します。" & vbCrLf & vbCrLf & _
          "振り分け先：" & basePath & vbCrLf & _
          "元フォルダ：" & srcPath & vbCrLf & _
          "フォルダ数：" & (lastRow - 1) & " 件" & vbCrLf & vbCrLf & _
          "【注意】ファイル移動は元フォルダからファイルがなくなる操作です。" & vbCrLf & _
          "バックアップは取りましたか？" & vbCrLf & vbCrLf & _
          "実行しますか？"

    If MsgBox(msg, vbYesNo + vbExclamation) = vbNo Then
        Set fso = Nothing
        Exit Sub
    End If

    '--- C列（ログ列）をクリア
    ws.Range("C:C").Clear
    ws.Cells(1, 3).Value = "ログ"

    Dim folderCreateCount As Long
    Dim moveSuccessCount As Long
    Dim moveFailCount As Long
    Dim noMatchCount As Long

    '--- STEP1：フォルダを一括作成
    Dim i As Long
    Dim folderFullPath As String

    For i = 2 To lastRow
        If ws.Cells(i, 1).Value <> "" Then
            folderFullPath = basePath & ws.Cells(i, 1).Value
            If Not fso.FolderExists(folderFullPath) Then
                fso.CreateFolder folderFullPath
                ws.Cells(i, 3).Value = "フォルダ作成済み"
                folderCreateCount = folderCreateCount + 1
            Else
                ws.Cells(i, 3).Value = "フォルダ既存（スキップ）"
            End If
        End If
    Next i

    '--- STEP2：元フォルダ内のファイルをキーワードで振り分け
    Dim srcFolder As Object
    Set srcFolder = fso.GetFolder(srcPath)

    Dim file As Object
    Dim matched As Boolean
    Dim targetFolder As String
    Dim logText As String

    For Each file In srcFolder.Files

        matched = False

        '--- A列のキーワード（B列）と照合（上から順に判定）
        For i = 2 To lastRow

            Dim keyword As String
            keyword = ws.Cells(i, 2).Value

            If keyword <> "" Then
                '--- ファイル名にキーワードが含まれるか判定
                If InStr(1, file.Name, keyword, vbTextCompare) > 0 Then
                    targetFolder = basePath & ws.Cells(i, 1).Value & "\"

                    '--- 移動先に同名ファイルがないかチェック
                    If fso.FileExists(targetFolder & file.Name) Then
                        logText = file.Name & " → 失敗：移動先に同名ファイルが存在"
                        ws.Cells(i, 3).Value = ws.Cells(i, 3).Value & _
                            IIf(ws.Cells(i, 3).Value <> "" And _
                                Right(ws.Cells(i, 3).Value, 1) <> vbLf, _
                                " / ", "") & logText
                        moveFailCount = moveFailCount + 1
                        matched = True
                        Exit For
                    End If

                    '--- ファイルを移動
                    On Error Resume Next
                    fso.MoveFile file.Path, targetFolder & file.Name

                    If Err.Number = 0 Then
                        logText = file.Name & " → 移動成功"
                        moveSuccessCount = moveSuccessCount + 1
                    Else
                        logText = file.Name & " → 失敗：" & Err.Description
                        moveFailCount = moveFailCount + 1
                        Err.Clear
                    End If
                    On Error GoTo 0

                    '--- C列にログを追記
                    ws.Cells(i, 3).Value = ws.Cells(i, 3).Value & _
                        IIf(ws.Cells(i, 3).Value <> "" And _
                            Right(ws.Cells(i, 3).Value, 1) <> vbLf, _
                            " / ", "") & logText

                    matched = True
                    Exit For  '← 最初に一致したフォルダに振り分け（上から順に判定）
                End If
            End If

        Next i

        '--- どのキーワードにも一致しなかった場合
        If Not matched Then
            noMatchCount = noMatchCount + 1
        End If

    Next file

    Set fso = Nothing

    '--- 完了メッセージ
    MsgBox "完了しました。" & vbCrLf & vbCrLf & _
           "フォルダ作成：" & folderCreateCount & " 件" & vbCrLf & _
           "移動成功：" & moveSuccessCount & " 件" & vbCrLf & _
           "移動失敗：" & moveFailCount & " 件" & vbCrLf & _
           "振り分け先なし：" & noMatchCount & " 件" & vbCrLf & vbCrLf & _
           "C列にログを記録しました。", vbInformation

End Sub

書き換えポイント

変数	説明	初期値
`basePath`	振り分け先の親フォルダ（末尾に `\`）	`"C:\Users\（ユーザー名）\Desktop\振り分け先\"`
`srcPath`	元ファイルがあるフォルダ（末尾に `\`）	`"C:\Users\（ユーザー名）\Desktop\作業フォルダ\"`
`wsName`	フォルダ名・キーワードを入力したシート名	`"Sheet1"`

コードの流れ

CreateObject(“Scripting.FileSystemObject”): FileSystemObjectを作成（参照設定不要）
最終行の取得: A列のデータ数からフォルダの件数を自動検出する
存在チェック: 元フォルダと振り分け先の親フォルダが存在するか確認する
確認ダイアログ: フォルダ数と注意事項を表示し、実行してよいか確認する
STEP1 フォルダ一括作成: A列のフォルダ名を順に読み取り、fso.FolderExists で存在チェック → なければ fso.CreateFolder で作成
STEP2 ファイル振り分け: 元フォルダ内の各ファイルについて、B列のキーワードが含まれるかを InStr で判定 → 一致すれば fso.MoveFile で移動
ログ記録: C列に「フォルダ作成済み」「移動成功」「失敗：理由」を記録
完了メッセージ: フォルダ作成数・移動成功数・失敗数・振り分け先なし数をMsgBoxで表示

ポイント:

キーワードの照合は 上から順に判定 され、最初に一致したフォルダに振り分けられる。より具体的なキーワードを上の行に配置すること
InStr の第4引数に vbTextCompare を指定しているため、大文字・小文字を区別しない
キーワードが空欄のフォルダはフォルダ作成のみ行い、振り分け対象にはならない
どのキーワードにも一致しなかったファイルは元フォルダにそのまま残る
エラー処理は On Error Resume Next でファイル単位のエラーを捕捉し、次のファイルに進む。エラー処理の詳細はエラー処理で止まらないマクロを作る方法を参照

—