【初心者向け】シートデータをコード別に自動で分けるマクロの作り方

2025年5月6日 2025年5月18日

毎回、Excelの同じ作業に時間を取られていませんか？

たとえば「コードごとにデータを分けてシートを作成する」ような地味だけど面倒な作業…。

でも実は、それ、たった1クリックで自動化できるって知っていましたか？

この記事では、初心者の方でも安心して使える「コードごとにシートを分けるExcelマクロ」の使い方を、画像・手順付きでわかりやすく解説します。

ぜひご自身の作業に合わせて使ってみてください。

初心者向けコピペOK

・初心者向けエクセルマクロの作り方を解説｜コピペOK実務テンプレ付き

・【初心者向け】シートデータをコード別に自動で分けるマクロの作り方⇐ココ

・【初心者向け】シートデータをコード別に自動集計するマクロの作り方

・【初心者向け】コード別の日別集計と折線グラフ自動マクロの作り方

・【初心者向け】日別集計と折線グラフをシート名保存するマクロの作り方

1 初心者向けマクロの作り方｜コードごとに自動シート作成はどんなときに便利？
2 初心者向けマクロの作り方｜コードごとに自動シート作成できること
3 初心者向けマクロの作り方｜コードごとに自動シート作成の使い方はたったの3ステップ
4 初心者向けマクロの作り方｜コードごとに自動シート作成｜押さえるべき3つのポイント
5 初心者向けマクロの作り方｜コードごとに自動シート作成｜よく変更が行われる箇所
6 初心者向けマクロの作り方｜コードごとに自動シート作成【検証済】コード
7 初心者向けマクロの作り方｜コードごとに自動シート作成【検証済】コードの使い方
8 初心者向けマクロの作り方｜コードごとに自動シート作成であなたの作業はもっと楽になる
9 初心者向けマクロの作り方｜もし、ダメだ動かない。わからないなど気になることがあれば・・・

初心者向けマクロの作り方｜コードごとに自動シート作成はどんなときに便利？

Excelシートに同じ表形式のデータが大量にあるとき、「コードごとに別のシートに分けて保存したい…」ということはありませんか？

たとえば

・売上データ、仕入データなどのシートから
　・担当者コードシートごとに分ける
　・商品コードシートごとに分ける
　・得意先コードシートごとに分ける

・生産実績データのシートから
　・工場ラインコードごとに分ける

そんな時に便利なのが、この「コードごとに自動でシートを分けるマクロ」です。

初心者向けマクロの作り方｜コードごとに自動シート作成できること

1枚のシートにまとめられたデータから、指定した列（例：A列の「コード」）をキーにして、コードごとに新しいシートを作成し、データを分けて転記します。

手作業不要！「マクロ実行」だけですぐに完成します。

初心者向けマクロの作り方｜コードごとに自動シート作成の使い方はたったの3ステップ

1. 元データをExcelに準備する。

2. マクロを起動（フォームから対象のExcelとコード列を指定）

3. 各コードごとのシートが自動で作成されます。

もう、手作業でフィルタしてコピー＆ペーストする必要はありません。

初心者向けマクロの作り方｜コードごとに自動シート作成｜押さえるべき3つのポイント

①モジュール構成を覚えよう

「ThisWorkbook」→ 起動時にフォーム表示

「UserForm」→ フォームの見た目と操作

「標準モジュール」→ 実際の分割処理

②対象Excelフォーマット

コード列を統一しておく（たとえば、担当者コードはA列に統一する）

③トラブル対策

マクロを実行する前に、対象のExcelファイルをバックアップする（別フォルダにコピーをとる）

初心者向けマクロの作り方｜コードごとに自動シート作成｜よく変更が行われる箇所

変更箇所	内容	たとえば、このように変更
wb.Sheets(1)	データがあるシートを指定	wb.Sheets(2)
newWS.Name = code	シート名の形式	”担当 ” & code

初心者向けマクロの作り方｜コードごとに自動シート作成【検証済】コード

シートデータをコード別に自動で分ける【検証済】マクロコード一式（フォーム＋標準モジュール＋ThisWorkbook）を紹介します。

ThisWorkbook モジュール

xlsmファイルを開いたときに自動でフォームを表示するコードです。

Option Explicit
Private Sub Workbook_Open()
UserForm1.Show vbModeless
End Sub

Option Explicit
Private Sub Workbook_Open()
UserForm1.Show vbModeless
End Sub

フォーム

フォームのデザイン

オブジェクト名	種類	キャプション
変更しない	Label	対象Excelファイル
txtFile	TextBox	空白
btnBrowse	CommandButton	ファイル選択
変更しない	Label	コード列（例：A）
txtColumn	TextBox	空白
btnSplit	CommandButton	データを分ける
btnClose	CommandButton	終了

フォームのコード（UserForm1）

Option Explicit
Private Sub UserForm_Initialize()
' Excelウィンドウを最小化し、フォームを前面に出す
Application.WindowState = xlMinimized
Me.StartUpPosition = 1 ' 画面中央
Me.Show vbModeless
End Sub
Private Sub btnBrowse_Click()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Excelファイルを選択してください"
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If .Show = -1 Then
txtFile.Text = .SelectedItems(1)
End If
End With
End Sub
Private Sub btnSplit_Click()
Application.ScreenUpdating = False
Dim colLetter As String
colLetter = UCase(txtColumn.Text) ' 大文字に統一
' 列記号が正しいかと、2行目のセルに値があるか確認
Dim wb As Workbook
Set wb = Workbooks.Open(txtFile.Text)
Dim srcWs As Worksheet
Set srcWs = wb.Sheets(1) ' 最初のシートを対象に
Dim checkValue As Variant
On Error Resume Next
checkValue = srcWs.Range(colLetter & "2").Value
On Error GoTo 0
' 列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
If IsEmpty(checkValue) Or checkValue = "" Then
MsgBox "範囲外の列指定になっています。" & vbCrLf & _
"指定した列の2行目に値がありません。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
If txtFile.Text = "" Or txtColumn.Text = "" Then
MsgBox "ファイルと列を指定してください", vbExclamation
Exit Sub
End If
' データ処理を実行
Call 分割処理(txtFile.Text, txtColumn.Text)
End Sub
Private Sub btnClose_Click()
Application.WindowState = xlNormal
ThisWorkbook.Save
Application.Quit
End Sub
Function IsValidColumnLetter(colLetter As String) As Boolean
On Error GoTo ErrHandler
Dim rng As Range
Set rng = Worksheets(1).Range(colLetter & "1")
IsValidColumnLetter = True
Exit Function
ErrHandler:
IsValidColumnLetter = False
End Function

標準モジュール（Module1）

Option Explicit
Public Sub 分割処理(ByVal filePath As String, ByVal codeColumn As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim ws As Worksheet
Dim header As Range
Dim lastRow As Long
Dim colNum As Long
Dim code As Variant
Dim cell As Range
Dim rng As Range
Dim newWS As Worksheet
Dim destWB As Workbook
Dim existingCodes As Object
Set wb = Workbooks.Open(filePath)
Set ws = wb.Sheets(1)
' コード列番号取得
colNum = Range(codeColumn & "1").Column
lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
' ソート
Set rng = ws.Range("A1", ws.Cells(lastRow, ws.Cells(1, Columns.Count).End(xlToLeft).Column))
rng.Sort Key1:=ws.Cells(2, colNum), Order1:=xlAscending, header:=xlYes
' すでにシートが存在しているか確認
Set existingCodes = CreateObject("Scripting.Dictionary")
For Each newWS In wb.Sheets
existingCodes(newWS.Name) = True
Next
' コード列ごとに処理
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 2 To lastRow
code = Trim(ws.Cells(i, colNum).Value)
If code <> "" Then
If Not dict.exists(code) Then
dict.Add code, Nothing
End If
End If
Next
' すでにシートがあるかチェック
Dim alreadyExists As Boolean: alreadyExists = False
For Each code In dict.Keys
If existingCodes.exists(code) Then
alreadyExists = True
Exit For
End If
Next
If alreadyExists Then
MsgBox "すでにシート分けしています", vbInformation
wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If
' シート分割
For Each code In dict.Keys
Set newWS = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
newWS.Name = code
' ヘッダー
ws.Rows(1).Copy Destination:=newWS.Rows(1)
Dim destRow As Long: destRow = 2
For i = 2 To lastRow
If Trim(ws.Cells(i, colNum).Value) = code Then
ws.Rows(i).Copy Destination:=newWS.Rows(destRow)
destRow = destRow + 1
End If
Next i
newWS.Cells.EntireColumn.AutoFit
Next code
wb.Save
wb.Close
MsgBox "シートの分割が完了しました", vbInformation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

初心者向けマクロの作り方｜コードごとに自動シート作成【検証済】コードの使い方

以下手順で、シートデータをコード別に自動で分けるマクロは完成します。

フォームはコードがないので、ご自身で作成することになりますが、その他のコードは、【検証済】コードをコピペすればマクロができます。※フォーム作成方法も、下記で詳しく説明しますので、ご安心ください。

Excel起動からユーザーフォーム作成の操作

対象Excelファイル

ファイル選択

コード列（例：A）、データを分ける、終了

txtFile

btnBrowse

txtColumn

btnSplit

btnClose

【検証済】コードをコピペ

下記、ThisWorkbookモジュールをコピーします

Option Explicit
Private Sub Workbook_Open()
UserForm1.Show vbModeless
End Sub

下記、フォームのコードをコピーします

Option Explicit
Private Sub UserForm_Initialize()
' Excelウィンドウを最小化し、フォームを前面に出す
Application.WindowState = xlMinimized
Me.StartUpPosition = 1 ' 画面中央
Me.Show vbModeless
End Sub
Private Sub btnBrowse_Click()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Excelファイルを選択してください"
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If .Show = -1 Then
txtFile.Text = .SelectedItems(1)
End If
End With
End Sub
Private Sub btnSplit_Click()
Application.ScreenUpdating = False
Dim colLetter As String
colLetter = UCase(txtColumn.Text) ' 大文字に統一
' 列記号が正しいかと、2行目のセルに値があるか確認
Dim wb As Workbook
Set wb = Workbooks.Open(txtFile.Text)
Dim srcWs As Worksheet
Set srcWs = wb.Sheets(1) ' 最初のシートを対象に
Dim checkValue As Variant
On Error Resume Next
checkValue = srcWs.Range(colLetter & "2").Value
On Error GoTo 0
' 列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
If IsEmpty(checkValue) Or checkValue = "" Then
MsgBox "範囲外の列指定になっています。" & vbCrLf & _
"指定した列の2行目に値がありません。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
If txtFile.Text = "" Or txtColumn.Text = "" Then
MsgBox "ファイルと列を指定してください", vbExclamation
Exit Sub
End If
' データ処理を実行
Call 分割処理(txtFile.Text, txtColumn.Text)
End Sub
Private Sub btnClose_Click()
Application.WindowState = xlNormal
ThisWorkbook.Save
Application.Quit
End Sub
Function IsValidColumnLetter(colLetter As String) As Boolean
On Error GoTo ErrHandler
Dim rng As Range
Set rng = Worksheets(1).Range(colLetter & "1")
IsValidColumnLetter = True
Exit Function
ErrHandler:
IsValidColumnLetter = False
End Function

下記、標準モジュールをコピーします

Option Explicit
Public Sub 分割処理(ByVal filePath As String, ByVal codeColumn As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim ws As Worksheet
Dim header As Range
Dim lastRow As Long
Dim colNum As Long
Dim code As Variant
Dim cell As Range
Dim rng As Range
Dim newWS As Worksheet
Dim destWB As Workbook
Dim existingCodes As Object
Set wb = Workbooks.Open(filePath)
Set ws = wb.Sheets(1)
' コード列番号取得
colNum = Range(codeColumn & "1").Column
lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
' ソート
Set rng = ws.Range("A1", ws.Cells(lastRow, ws.Cells(1, Columns.Count).End(xlToLeft).Column))
rng.Sort Key1:=ws.Cells(2, colNum), Order1:=xlAscending, header:=xlYes
' すでにシートが存在しているか確認
Set existingCodes = CreateObject("Scripting.Dictionary")
For Each newWS In wb.Sheets
existingCodes(newWS.Name) = True
Next
' コード列ごとに処理
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 2 To lastRow
code = Trim(ws.Cells(i, colNum).Value)
If code <> "" Then
If Not dict.exists(code) Then
dict.Add code, Nothing
End If
End If
Next
' すでにシートがあるかチェック
Dim alreadyExists As Boolean: alreadyExists = False
For Each code In dict.Keys
If existingCodes.exists(code) Then
alreadyExists = True
Exit For
End If
Next
If alreadyExists Then
MsgBox "すでにシート分けしています", vbInformation
wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If
' シート分割
For Each code In dict.Keys
Set newWS = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
newWS.Name = code
' ヘッダー
ws.Rows(1).Copy Destination:=newWS.Rows(1)
Dim destRow As Long: destRow = 2
For i = 2 To lastRow
If Trim(ws.Cells(i, colNum).Value) = code Then
ws.Rows(i).Copy Destination:=newWS.Rows(destRow)
destRow = destRow + 1
End If
Next i
newWS.Cells.EntireColumn.AutoFit
Next code
wb.Save
wb.Close
MsgBox "シートの分割が完了しました", vbInformation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub