Excelファイル仕分けマニュアル（VBA版）
250店舗分のExcelファイルを、担当者ごとのフォルダに定期的に仕分け直す方法をまとめます。
数か月に1回店舗の担当者が変わるのですがその都度手動でファイルを移動させるのがとてもめんどくさいので、ChatGPTにコードを書いてもらってVBAで一気にやることにしました。
手順概要
- 対象フォルダ内のExcelファイル名を一覧化
- 仕分けルール（ファイル名と担当者フォルダの対応表）を作成
- VBAマクロで一括仕分けを実行
1. フォルダ内のファイル名を一覧化（PowerShell）
PowerShellで指定フォルダ内のExcelファイルを取得し、CSVに出力します。
※コードは以下の通り修正する
1行目のC:\Work：取得したいファイルが入っているフォルダのパス
3行目のC:\Work\：出力する場所のパス
Get-ChildItem "C:\Work" -Filter *.xlsx |
Select-Object Name, FullName |
Export-Csv "C:\Work\ExcelFileList.csv" -NoTypeInformation -Encoding UTF8
2. 仕分けルールの作成
ExcelまたはCSVで以下の形式の対応表を作成します。
| FileName | Destination |
|---|---|
| 12345_店名_目標管理表.xlsx-ショートカット | 堀口 |
| 12346_店名_目標管理表.xlsx-ショートカット | 萩原 |
-
FileName … ファイル名（拡張子を含んでもOK、ショートカットの場合は
.lnkを除いたベース名で可） - Destination … 仕分け先フォルダ名（担当者名など）
3. VBAマクロの実行
以下のVBAコードを2で作った仕分け一覧シートを開き、Alt＋F11でVBAを起動し
以下のコード貼り付け
VBA
Option Explicit
Sub MoveShortcuts_Safe()
Dim ws As Worksheet, logWs As Worksheet
Dim srcFolder As String, destBase As String
Dim lastRow As Long, i As Long
Dim colFile As Long, colDest As Long
Dim fname As String, dest As String
Dim srcPath As String, destFolder As String, destPath As String
Dim fso As Object
'==== ここをあなたの環境に合わせて ====
srcFolder = "C:\Work\Shortcuts\" ' ショートカットがあるフォルダ
destBase = "C:\Work\Sorted\" ' 仕分け先のベースフォルダ
'========================================
' シート自動検出：アクティブシートを使う（固定したい場合は Sheets("あなたのシート名") に）
Set ws = ActiveSheet
' ヘッダーの列位置を探す（1行目）
colFile = FindHeaderColumn(ws, "FileName")
colDest = FindHeaderColumn(ws, "Destination")
If colFile = 0 Or colDest = 0 Then
MsgBox "ヘッダー行に 'FileName' または 'Destination' が見つかりません。" & vbCrLf & _
"スペル・全角/半角・余分な空白を確認してください。", vbExclamation
Exit Sub
End If
' データ最終行
lastRow = ws.Cells(ws.Rows.Count, colFile).End(xlUp).Row
If lastRow < 2 Then
MsgBox "データ行がありません（ヘッダーのみ）。", vbExclamation
Exit Sub
End If
' フォルダ末尾の \ を保証
If Right$(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\"
If Right$(destBase, 1) <> "\" Then destBase = destBase & "\"
' FSO
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(srcFolder) Then
MsgBox "仕分け元フォルダが見つかりません: " & srcFolder, vbCritical
Exit Sub
End If
If Not fso.FolderExists(destBase) Then fso.CreateFolder destBase
' ログシート用意
On Error Resume Next
Set logWs = ThisWorkbook.Worksheets("SortLog")
On Error GoTo 0
If logWs Is Nothing Then
Set logWs = ThisWorkbook.Worksheets.Add
logWs.Name = "SortLog"
Else
logWs.Cells.Clear
End If
logWs.Range("A1:D1").Value = Array("Row", "FileName", "Destination", "Result")
Dim logRow As Long: logRow = 2
' 仕分け本体
For i = 2 To lastRow
fname = Trim$(ws.Cells(i, colFile).Value)
dest = Trim$(ws.Cells(i, colDest).Value)
If fname <> "" And dest <> "" Then
' .lnk 付与の有無を吸収（ベース名 or すでに .lnk を含む両対応）
If LCase$(Right$(fname, 4)) = ".lnk" Then
srcPath = srcFolder & fname
destPath = destBase & dest & "\" & fname
Else
srcPath = srcFolder & fname & ".lnk"
destPath = destBase & dest & "\" & fname & ".lnk"
End If
destFolder = fso.GetParentFolderName(destPath)
If Not fso.FolderExists(destFolder) Then fso.CreateFolder destFolder
If fso.FileExists(srcPath) Then
On Error Resume Next
fso.MoveFile srcPath, destPath
If Err.Number = 0 Then
logWs.Cells(logRow, 1).Resize(1, 4).Value = Array(i, fname, dest, "Moved")
Else
logWs.Cells(logRow, 1).Resize(1, 4).Value = Array(i, fname, dest, "Error: " & Err.Description)
Err.Clear
End If
On Error GoTo 0
Else
logWs.Cells(logRow, 1).Resize(1, 4).Value = Array(i, fname, dest, "Not found: " & srcPath)
End If
logRow = logRow + 1
End If
Next i
MsgBox "完了しました。ログは 'SortLog' シートをご確認ください。", vbInformation
End Sub
Private Function FindHeaderColumn(ws As Worksheet, headerText As String) As Long
Dim rng As Range
Set rng = ws.Rows(1).Find(What:=headerText, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
If rng Is Nothing Then
FindHeaderColumn = 0
Else
FindHeaderColumn = rng.Column
End If
End Function
終わり！！簡単でした！
今回はExcel本体は動かさず、250個のExcelのショートカットを作成しそれをフォルダ分けしました。
仕分けしなおすときは
フォルダごと全ショートカットを削除
→250個のショートカット作成しなおし
→上記の手順
担当者ごとのフォルダも自動で作成されるので準備不要！（多分）
この自動化によって月によっては30分程度の時間削減になるかも。