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

2025年5月8日 2025年5月18日

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

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

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

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

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

初心者向けコピペOK

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

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

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

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

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

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

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

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

たとえば

・データのコードごとに日別集計シートを自動で作成する
　・担当者コード、商品コード、得意先コード・・・ごとにシートを分けた日別集計

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

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

1枚のシートにまとめられたデータから、指定したコード列、日付列、金額列をもとに、コードごと日付、金額で集計し、コードごとにシートを分けて転記。

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

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

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

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

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

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

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

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

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

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

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

②対象Excelフォーマット

コード列を統一しておく（たとえば、担当者コードはA列に統一する、日付列はB列、金額列はC列など）

③トラブル対策

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

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

変更箇所（追加）	内容	たとえば、このように変更
newWS.Name = codeKey	シート名を「コード＋日付」などにする	newWS.Name = codeKey & "_" & Format(Date, "yyyymmdd")
newWS.Range("C1") = "追加列名	出力する列を追加する	ループ内で値を入れるコードを追加

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

シートごとにコード別日別集計する【検証済】マクロコード一式（フォーム＋標準モジュール＋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）
txtCodeCol	TextBox	空白
変更しない	Label	日付列（例：A）
txtDateCol	TextBox	空白
変更しない	Label	金額列（例：A）
txtAmountCol	TextBox	空白
btnAggregate	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.Clear
.Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls"
If .Show = -1 Then
txtFile.Text = .SelectedItems(1)
End If
End With
End Sub
Private Sub btnAggregate_Click()
If txtFile.Text = "" Or txtCodeCol.Text = "" Or txtDateCol.Text = "" Or txtAmountCol.Text = "" Then
MsgBox "ファイルと各列をすべて指定してください", vbExclamation
Exit Sub
End If
If txtCodeCol.Text = txtDateCol.Text Then
MsgBox "コード列と日付列に同じ値は指定できません", vbExclamation
Exit Sub
End If
If txtCodeCol.Text = txtAmountCol.Text Then
MsgBox "コード列と金額列に同じ値は指定できません", vbExclamation
Exit Sub
End If
If txtDateCol.Text = txtAmountCol.Text Then
MsgBox "日付列と金額列に同じ値は指定できません", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Dim colLetter As String
colLetter = UCase(txtCodeCol.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
colLetter = UCase(txtDateCol.Text) ' 大文字に統一
' 日付列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "日付列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
colLetter = UCase(txtAmountCol.Text) ' 大文字に統一
' 金額列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "金額列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
' 実行
Call 集計処理(txtFile.Text, UCase(txtCodeCol.Text), UCase(txtDateCol.Text), UCase(txtAmountCol.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 集計処理(filePath As String, codeCol As String, dateCol As String, amountCol As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim codeDict As Object: Set codeDict = CreateObject("Scripting.Dictionary")
Dim codeColNum As Long
Dim dateColNum As Long
Dim amountColNum As Long
Set wb = Workbooks.Open(filePath)
Set ws = wb.Sheets(1)
' 列番号取得
codeColNum = Range(codeCol & "1").Column
dateColNum = Range(dateCol & "1").Column
amountColNum = Range(amountCol & "1").Column
lastRow = ws.Cells(ws.Rows.Count, codeColNum).End(xlUp).row
' ソート
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=ws.Cells(2, codeColNum), Order:=xlAscending
ws.Sort.SortFields.Add Key:=ws.Cells(2, dateColNum), Order:=xlAscending
With ws.Sort
.SetRange ws.Range("A1", ws.Cells(lastRow, ws.Cells(1, Columns.Count).End(xlToLeft).Column))
.header = xlYes
.Apply
End With
' コードごとにデータ格納
Dim i As Long
For i = 2 To lastRow
Dim code As String, dt As String, amt As Double
code = Trim(ws.Cells(i, codeColNum).Value)
dt = Format(ws.Cells(i, dateColNum).Value, "yyyy/mm/dd")
amt = ws.Cells(i, amountColNum).Value
If code <> "" And dt <> "" And IsNumeric(amt) Then
If Not codeDict.exists(code) Then
codeDict.Add code, CreateObject("Scripting.Dictionary")
End If
With codeDict(code)
If .exists(dt) Then
.Item(dt) = .Item(dt) + amt
Else
.Add dt, amt
End If
End With
End If
Next i
' シート作成
Dim codeKey As Variant
For Each codeKey In codeDict.Keys
If シート存在チェック(wb, codeKey) Then
MsgBox "コード [" & codeKey & "] のシートはすでに存在します。処理を中止します。", vbInformation
wb.Close SaveChanges:=False
GoTo EndProc
End If
Dim newWS As Worksheet
Set newWS = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
newWS.Name = codeKey
' ヘッダー
newWS.Range("A1") = "日付"
newWS.Range("B1") = "合計金額"
' データ出力
Dim row As Long: row = 2
Dim dtKey As Variant
For Each dtKey In codeDict(codeKey).Keys
newWS.Cells(row, 1).Value = dtKey
newWS.Cells(row, 2).Value = codeDict(codeKey)(dtKey)
row = row + 1
Next dtKey
newWS.Cells.EntireColumn.AutoFit
Next codeKey
wb.Save
wb.Close SaveChanges:=True
MsgBox "集計完了しました", vbInformation
EndProc:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function シート存在チェック(wb As Workbook, codeKey As Variant) As Boolean
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name = codeKey Then
シート存在チェック = True
Exit Function
End If
Next
シート存在チェック = False
End Function

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

以下手順で、シートごとにコード別日別集計するマクロは完成します。

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

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

対象Excelファイル

ファイル選択

コード列（例：A）から終了まで

txtFile

btnBrowse

txtCodeCol

txtDateCol

txtAmountCol

btnAggregate

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.Clear
.Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls"
If .Show = -1 Then
txtFile.Text = .SelectedItems(1)
End If
End With
End Sub
Private Sub btnAggregate_Click()
If txtFile.Text = "" Or txtCodeCol.Text = "" Or txtDateCol.Text = "" Or txtAmountCol.Text = "" Then
MsgBox "ファイルと各列をすべて指定してください", vbExclamation
Exit Sub
End If
If txtCodeCol.Text = txtDateCol.Text Then
MsgBox "コード列と日付列に同じ値は指定できません", vbExclamation
Exit Sub
End If
If txtCodeCol.Text = txtAmountCol.Text Then
MsgBox "コード列と金額列に同じ値は指定できません", vbExclamation
Exit Sub
End If
If txtDateCol.Text = txtAmountCol.Text Then
MsgBox "日付列と金額列に同じ値は指定できません", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Dim colLetter As String
colLetter = UCase(txtCodeCol.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
colLetter = UCase(txtDateCol.Text) ' 大文字に統一
' 日付列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "日付列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
colLetter = UCase(txtAmountCol.Text) ' 大文字に統一
' 金額列記号の妥当性チェック
If Not IsValidColumnLetter(colLetter) Then
MsgBox "金額列記号が無効です。" & vbCrLf & "A ? XFD の範囲で入力してください。", vbExclamation
Application.ScreenUpdating = True ' MsgBox後に復元
wb.Close SaveChanges:=False
Exit Sub
End If
Application.ScreenUpdating = True
' 実行
Call 集計処理(txtFile.Text, UCase(txtCodeCol.Text), UCase(txtDateCol.Text), UCase(txtAmountCol.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 集計処理(filePath As String, codeCol As String, dateCol As String, amountCol As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim codeDict As Object: Set codeDict = CreateObject("Scripting.Dictionary")
Dim codeColNum As Long
Dim dateColNum As Long
Dim amountColNum As Long
Set wb = Workbooks.Open(filePath)
Set ws = wb.Sheets(1)
' 列番号取得
codeColNum = Range(codeCol & "1").Column
dateColNum = Range(dateCol & "1").Column
amountColNum = Range(amountCol & "1").Column
lastRow = ws.Cells(ws.Rows.Count, codeColNum).End(xlUp).row
' ソート
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=ws.Cells(2, codeColNum), Order:=xlAscending
ws.Sort.SortFields.Add Key:=ws.Cells(2, dateColNum), Order:=xlAscending
With ws.Sort
.SetRange ws.Range("A1", ws.Cells(lastRow, ws.Cells(1, Columns.Count).End(xlToLeft).Column))
.header = xlYes
.Apply
End With
' コードごとにデータ格納
Dim i As Long
For i = 2 To lastRow
Dim code As String, dt As String, amt As Double
code = Trim(ws.Cells(i, codeColNum).Value)
dt = Format(ws.Cells(i, dateColNum).Value, "yyyy/mm/dd")
amt = ws.Cells(i, amountColNum).Value
If code <> "" And dt <> "" And IsNumeric(amt) Then
If Not codeDict.exists(code) Then
codeDict.Add code, CreateObject("Scripting.Dictionary")
End If
With codeDict(code)
If .exists(dt) Then
.Item(dt) = .Item(dt) + amt
Else
.Add dt, amt
End If
End With
End If
Next i
' シート作成
Dim codeKey As Variant
For Each codeKey In codeDict.Keys
If シート存在チェック(wb, codeKey) Then
MsgBox "コード [" & codeKey & "] のシートはすでに存在します。処理を中止します。", vbInformation
wb.Close SaveChanges:=False
GoTo EndProc
End If
Dim newWS As Worksheet
Set newWS = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
newWS.Name = codeKey
' ヘッダー
newWS.Range("A1") = "日付"
newWS.Range("B1") = "合計金額"
' データ出力
Dim row As Long: row = 2
Dim dtKey As Variant
For Each dtKey In codeDict(codeKey).Keys
newWS.Cells(row, 1).Value = dtKey
newWS.Cells(row, 2).Value = codeDict(codeKey)(dtKey)
row = row + 1
Next dtKey
newWS.Cells.EntireColumn.AutoFit
Next codeKey
wb.Save
wb.Close SaveChanges:=True
MsgBox "集計完了しました", vbInformation
EndProc:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function シート存在チェック(wb As Workbook, codeKey As Variant) As Boolean
Dim ws As Worksheet
For Each ws In wb.Sheets
If ws.Name = codeKey Then
シート存在チェック = True
Exit Function
End If
Next
シート存在チェック = False
End Function