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

2025年5月14日 2025年5月18日

「毎月、担当者別・日別に集計して、グラフを作って…手間がかかって大変！」

そんなあなたに朗報です。

本記事では、Excel VBAで元データを自動でコード別に集計し、日別折れ線グラフまで作成＆シート別にブック保存してくれるマクロをご紹介します。

初心者でもすぐ使えるように、使い方の3ステップや注意点をわかりやすく解説しています。

繰り返しの作業から解放されたい方、ぜひこのマクロで業務の効率化を体験してみてください！

「Excelマクロって難しそう」と感じていたあなたにこそ、試してほしい内容です！

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

初心者向けコピペOK

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

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

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

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

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

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

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存｜どんなときに便利？

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

たとえば

・集計表、グラフを作成したあと、担当者別や部署別に配布するので、シートごとにわけてブックを作成したい。

・ひとつのブックから配布ごとに分けて保存する時間を取られたくない！

そんなあなたにピッタリなのが、この「日別集計と折線グラフをシート名で保存するマクロ」です。

ファイルを選んで集計ボタンを押すだけで、自動で集計＋折れ線グラフ+シート別にブック作成。

Excel初心者の方でも安心して使えます。

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存｜できること

1枚のシートにまとめられたデータから、指定したコード列、日付列、金額列をもとに、コードごと日付、金額で集計し、コードごとにシートを分けて転記。転記した内容をもとに折れ線グラフを作成、そして、シートごとにシート名をブック名として保存。

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

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存｜使い方はたったの3ステップ

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

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

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

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

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存｜押さえるべき3つのポイント

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

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

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

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

②対象Excelフォーマット

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

③トラブル対策

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

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存｜よく変更が行われる箇所

変更箇所（追加）	内容	たとえば、このように変更
保存先のフォルダを指定	newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook	savePath を変更すればOK

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存【検証済】コード

シートごとにコード別日別集計＆折線グラフを作成する【検証済】マクロコード一式（フォーム＋標準モジュール＋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
Call 折れ線グラフを作成する(filePath)
Call コード別シートを個別ブックに保存(filePath)
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
Public Sub 折れ線グラフを作成する(filePath As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim chartObj As ChartObject
Dim chartRange As Range
Set wb = Workbooks.Open(filePath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
' 「集計元」シート（最初のシート）はスキップする（必要に応じて変更可能）
If ws.Index = 1 Then GoTo NextSheet
' 最終行の取得（A列を基準）
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
' データが2行以上あるか確認
If lastRow < 2 Then GoTo NextSheet
' グラフ範囲の指定（A列：日付、B列：合計金額）
Set chartRange = ws.Range("A1:B" & lastRow)
' グラフ作成
Set chartObj = ws.ChartObjects.Add(Left:=300, Top:=10, Width:=500, Height:=300)
With chartObj.Chart
.ChartType = xlLine
.SetSourceData Source:=chartRange
.HasTitle = True
.ChartTitle.Text = "日別売上推移"
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Text = "日付"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Text = "合計金額"
.SeriesCollection(1).ApplyDataLabels
End With
NextSheet:
Next ws
wb.Save
wb.Close SaveChanges:=True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Public Sub コード別シートを個別ブックに保存(filePath As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Set wb = Workbooks.Open(filePath)
Dim folderPath As String
folderPath = Left(filePath, InStrRev(filePath, "\")) ' フォルダのパス
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Index <> 1 Then
' 最初のシートは「元データ」とみなしてスキップ
' 新しいブックを作成
Dim newWb As Workbook
Set newWb = Workbooks.Add(xlWBATWorksheet)
' 最初のシートに元のシートの内容をコピー
ws.Cells.Copy Destination:=newWb.Sheets(1).Cells(1, 1)
newWb.Sheets(1).Name = ws.Name
' ★ 横軸（例：A列）が日付の場合、表示形式を「yyyy/m/d」に
newWb.Sheets(1).Columns(1).NumberFormat = "yyyy/m/d"
' ★ 外部リンクがあれば削除（セキュリティ警告回避）
Dim link As Variant
On Error Resume Next ' リンクがない場合のエラー対策
For Each link In newWb.LinkSources(Type:=xlLinkTypeExcelLinks)
newWb.BreakLink Name:=link, Type:=xlLinkTypeExcelLinks
Next link
On Error GoTo 0
' 保存パス作成
Dim savePath As String
savePath = folderPath & ws.Name & ".xlsx"
' 上書き保存
Application.DisplayAlerts = False
newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
newWb.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
Next ws
wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

初心者向けマクロの作り方｜日別集計と折線グラフをシート名保存【検証済】コードの使い方

以下手順で、シートごとにコード別日別集計＆折線グラフ作成、シートごとにシート名をブック名として保存するマクロは完成します。

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

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
Call 折れ線グラフを作成する(filePath)
Call コード別シートを個別ブックに保存(filePath)
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
Public Sub 折れ線グラフを作成する(filePath As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim chartObj As ChartObject
Dim chartRange As Range
Set wb = Workbooks.Open(filePath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
' 「集計元」シート（最初のシート）はスキップする（必要に応じて変更可能）
If ws.Index = 1 Then GoTo NextSheet
' 最終行の取得（A列を基準）
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
' データが2行以上あるか確認
If lastRow < 2 Then GoTo NextSheet
' グラフ範囲の指定（A列：日付、B列：合計金額）
Set chartRange = ws.Range("A1:B" & lastRow)
' グラフ作成
Set chartObj = ws.ChartObjects.Add(Left:=300, Top:=10, Width:=500, Height:=300)
With chartObj.Chart
.ChartType = xlLine
.SetSourceData Source:=chartRange
.HasTitle = True
.ChartTitle.Text = "日別売上推移"
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Text = "日付"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Text = "合計金額"
.SeriesCollection(1).ApplyDataLabels
End With
NextSheet:
Next ws
wb.Save
wb.Close SaveChanges:=True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Public Sub コード別シートを個別ブックに保存(filePath As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
Set wb = Workbooks.Open(filePath)
Dim folderPath As String
folderPath = Left(filePath, InStrRev(filePath, "\")) ' フォルダのパス
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Index <> 1 Then
' 最初のシートは「元データ」とみなしてスキップ
' 新しいブックを作成
Dim newWb As Workbook
Set newWb = Workbooks.Add(xlWBATWorksheet)
' 最初のシートに元のシートの内容をコピー
ws.Cells.Copy Destination:=newWb.Sheets(1).Cells(1, 1)
newWb.Sheets(1).Name = ws.Name
' ★ 横軸（例：A列）が日付の場合、表示形式を「yyyy/m/d」に
newWb.Sheets(1).Columns(1).NumberFormat = "yyyy/m/d"
' ★ 外部リンクがあれば削除（セキュリティ警告回避）
Dim link As Variant
On Error Resume Next ' リンクがない場合のエラー対策
For Each link In newWb.LinkSources(Type:=xlLinkTypeExcelLinks)
newWb.BreakLink Name:=link, Type:=xlLinkTypeExcelLinks
Next link
On Error GoTo 0
' 保存パス作成
Dim savePath As String
savePath = folderPath & ws.Name & ".xlsx"
' 上書き保存
Application.DisplayAlerts = False
newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
newWb.Close SaveChanges:=False
Application.DisplayAlerts = True
End If
Next ws
wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub