もう手作業は不要！VBAでフォルダ内のファイルを自動振り分けする方法【初心者OK】」

You

7日前

あなたはファイルを担当別のフォルダへ振り分けるとき、１つずつ手作業で保存するのを自動化できたらいいのにと思ったことはありませんか？

1つのフォルダに入れておけば、勝手に担当者フォルダに振り分けてくれたらラクですよね。

エクセルのマクロを使うと、リストを作っておけば担当フォルダへファイルの自動振り分けできます。担当が変わってもリストを修正すればいいので、変更があっても簡単に対応できて便利です。

今回は「VBAでフォルダ内のファイルを自動振り分けする方法」を紹介します。

VBAでフォルダ内のファイルを自動振り分けする方法
まとめ

VBAでフォルダ内のファイルを自動振り分けする方法

VBAでフォルダ内のファイルを自動振り分けするマクロを作る方法です。

ファイル名の先頭に、担当者「A」や「B」の名前がついていて、リストに基づき、「A」フォルダ、「B」フォルダへ移動させるのを例に紹介します。

下準備として、リストを作っておきます。

担当者、保存先のフォルダ名、保存先のフォルダパスをリストにまとめておきます。

マクロを作るときは、「開発」タブを使います。
開発タブが出ていない方は、下のリンクで出し方を紹介していますので、まずは準備をお願いします。
→エクセルで開発タブを表示する方法

１．「開発」タブをクリック　→「挿入」をクリック　→「ボタン」をクリック

２．「新規作成」をクリック

３．コード入力画面が開く

４．コードを入力

コードを入力します。

赤枠部のコードです。

Option Explicit

Const SourceFolder As String = "C:\Users\*****\Desktop\まとめ"

Sub ボタン1_Click()
    Dim ws As Worksheet
    Dim lastRow As Integer
    Dim i As Integer
    Dim matchFound As Boolean
    Dim FileName As String
    Dim SourcePath As String
    Dim DestinationPath As String
    Dim FirstWord As String
    Dim FileList() As String
    Dim FileCount As Integer
    
    ' シートを設定（Sheet1を適宜変更）
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 画面更新をオフ（高速化）
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' データ範囲の最終行を取得（A列を基準）
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' **ファイルリストを最初に取得（これが重要！）**
    FileName = Dir(SourceFolder & "\*.*")
    FileCount = 0
    
    ' **すべてのファイル名を配列に格納**
    Do While FileName <> ""
        ReDim Preserve FileList(FileCount)
        FileList(FileCount) = FileName
        FileCount = FileCount + 1
        FileName = Dir() ' 次のファイルを取得
    Loop

    ' **取得したファイルリストを1つずつ処理**
    Dim j As Integer
    For j = 0 To FileCount - 1
        FileName = FileList(j)
        SourcePath = SourceFolder & "\" & FileName
        
        ' 全角スペースを半角スペースに統一
        FileName = Replace(FileName, "　", " ")
        
        ' 最初の単語（姓）を取得
        FirstWord = Split(FileName, " ")(0) ' 半角スペースで区切って最初の要素を取得
        
        ' デバッグメッセージ（実行時に確認用）
        Debug.Print "処理中のファイル: " & FileName & " - 先頭の単語: " & FirstWord
        
        ' 初期化
        matchFound = False
        
        ' リスト内で一致する姓を検索
        For i = 2 To lastRow
            If ws.Cells(i, 1).Value = FirstWord Then
                DestinationPath = ws.Cells(i, 3).Value & "\" & FileName
                matchFound = True
                Exit For
            End If
        Next i
        
        ' 一致するフォルダがある場合のみ移動
        If matchFound Then
            If Dir(ws.Cells(i, 3).Value, vbDirectory) <> "" Then ' フォルダが存在するか確認
                FileCopy SourcePath, DestinationPath
                Kill SourcePath
            Else
                Debug.Print "フォルダが見つかりません: " & ws.Cells(i, 3).Value
            End If
        End If
    Next j
    
    ' 画面更新をオン（元に戻す）
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "ファイルの移動が完了しました！", vbInformation
End Sub

※*****のところは、適切なパスを入れて下さい。

５．ボタンができた　→ボタンを押す

ボタンができたら、ボタンを押しましょう。