業務報告に潜む「3重入力の罠」
皆さん、日々のお仕事で「日報」「週報」「ミーティング資料」など、何度も同じ内容を入力していて面倒だな… と思ったことはありませんか？
そんな現場のプチストレスを解消するため、毎日の業務記録から「週報」や「ミーティング資料」を自動生成するサポートツールの開発に挑戦しました！
全体構想と今回の実装範囲
[1次入力] プリザンター (業務記録データ蓄積)
│
│ API連携 (WinHttp) ＋ VBA辞書で集計 【★今回はここを実装！】
▼
[2次出力] Excel週報（PMOマスタ）へ自動流し込み
│
│ LLM (AI要約) ＋ Python/VBA (PPT自動生成) ※次回挑戦予定
▼
[最終出力] PowerPointミーティング資料
第一弾として作成したVBAツールは以下の5つです。
以下に、今回のツールを作成するに至った課題を含め記事にしました。
1. 現状の課題とツール構成
現在、部署内では用途に応じて3つのツールが分散して使われています。
- 業務記録：プリザンター（国産ローコードDB）➔ 日々の作業記録
- 週報：Excel ➔ 各プロジェクトの週間進捗確認
- ミーティング資料：PowerPoint ➔ 本部長への進捗報告・相談
見事なまでにツールが分散してしまっているのが現状です…
2. 解決したい課題
今回、以下の3つの課題を解消することを目指しました。
-
二重入力による転記コスト
- 業務記録と週報の双方へ同じような内容を手入力しており、重複入力が発生していた。
-
メンバーごとの「表記揺れ」
- 書き方が人によってバラバラで、案件毎にまとめにくい状態だった。
-
全自動化リスクへの配慮（Human-in-the-Loop設計）
- 送信まで完全自動化すると誤データの拡散リスクがあるため、あえて 「VBAで下書きを作成 ➔ 人間が最終確認」 というステップを挟み、安全に抽出内容をチェックできる運用ラインを構築しました。
3. 構築した自動化フローと設計アプローチ
課題を解決するため、以下のフローでVBAツールを設計・構築しました。
[プリザンターAPI]
│ (WinHttp + JScriptでデータ取得)
▼
[週データの自動抽出・ソート]
│ (週データ絞り込み & 人物別整理：指定週（月曜起点）のデータを自動抽出し、日付順にソート）
▼
[キーワード辞書による案件整理] ★工夫ポイント
│ (キーワード辞書による自動判定：「契約GD, SX...」などの表記揺れを「PMOマスタ案件名」にマッピング）
▼
[PMOマスタ（G列）への安全転記]
│ (既存コメントがある場合は改行追記し、データを上書き消失させない仕様）
▼
[人間による最終確認・修正]
💡 特に工夫したポイント：キーワード辞書による案件の自動振り分け
業務記録テキストの中から関連キーワードを検出し、どの案件の報告かをVBAが自動判別して適切な場所へ振り分ける設計にしました。
仕組み:
あらかじめ「案件」と「関連キーワード（表記の揺れや関連ワード）」を紐づけた辞書を持たせておきます。VBAが日報テキスト全体をスキャンし、合致するキーワードから該当する案件を割り当てます。
（キーワード辞書）
具体例:
業務記録内に「催事、一時使用」などの文字列がある
➔ 辞書を参照して「〇〇案件」と特定し、PMOマスタ内の該当案件の行へ自動振り分け
これにより、入力者に「指定フォーマットでの入力」を強いることなく、集計側も「どの案件の報告かを目視で判定・手動振り分けする」手間をゼロにできました。
🛡️ 安全性の担保（PMOマスタへの追記仕様）
自動転記の際、すでに転記先（G列）にデータが存在する場合は「改行して追記」するロジックを実装しました。これにより、既存のコメントや過去データを誤って上書き・消去してしまうリスクを防いでいます。
今回構築したVBAコード
VBAコードの作成には Gemini を活用しました。
💡 実装したVBAコード
今回はVBAコードが長いので折りたたんでいます。詳細は「▶」を押してご確認ください。
クリックで全体のVBAコードを表示（モジュール全体）
Option Explicit
===================================================================================
' 【ボタン1】プリザンターAPIから日報データを取得して「プリザンターデータ」シートへ出力
' ===================================================================================
Sub FetchPleasanterDataToSheet()
Dim http As Object
Dim url As String, siteId As String, apiKey As String
Dim jsonBody As String
Dim responseText As String
' ① 設定情報
url = "https://your-domain.com/api/items/"
siteId = "XXXXXX"
apiKey = "YOUR_API_KEY_HERE"
' ② 通信設定（Windows統合認証）
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
http.SetAutoLogonPolicy 0
http.Open "POST", url & siteId & "/get", False
http.setRequestHeader "Content-Type", "application/json; charset=utf-8"
' ③ リクエストデータの作成（最新100件を取得）
jsonBody = "{" & _
"""ApiKey"": """ & apiKey & """," & _
"""PageSize"": 100," & _
"""View"": {" & _
"""ColumnFilterHash"": {}" & _
"}" & _
"}"
' ④ 送信とレスポンス取得
http.Send jsonBody
If http.Status <> 200 Then
MsgBox "通信エラーが発生しました。Status: " & http.Status, vbCritical
Exit Sub
End If
responseText = http.responseText
' ⑤ Excelシート（「プリザンターデータ」）への出力処理
Call OutputToSheet(responseText)
MsgBox "「プリザンターデータ」シートへデータの読み込みが完了しました！", vbInformation, "1. API取得完了"
End Sub
Private Sub OutputToSheet(jsonText As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim sheetName As String
Set wb = ActiveWorkbook
sheetName = "プリザンターデータ"
' 「プリザンターデータ」シートの自動生成・選択
On Error Resume Next
Set ws = wb.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = sheetName
Else
ws.Cells.Clear
End If
' ヘッダー作成
ws.Range("A1:E1").Value = Array("ID", "タイトル", "更新日時", "DXメンバ", "業務記録本文")
ws.Range("A1:E1").Font.Bold = True
ws.Range("A1:E1").Interior.Color = RGB(220, 230, 241)
' JSONデータのパース
Dim html As Object, window As Object, json As Object, dataList As Object
Set html = CreateObject("htmlfile")
Set window = html.parentWindow
Dim jsCode As String
jsCode = "function getFieldValue(obj, prop) {" & _
" if (!obj) return '';" & _
" var val = '';" & _
" if (obj[prop] !== undefined && obj[prop] !== null) { val = obj[prop]; }" & _
" else if (obj.ClassHash && obj.ClassHash[prop] !== undefined) { val = obj.ClassHash[prop]; }" & _
" else if (obj.DescriptionHash && obj.DescriptionHash[prop] !== undefined) { val = obj.DescriptionHash[prop]; }" & _
" else if (obj.NumHash && obj.NumHash[prop] !== undefined) { val = obj.NumHash[prop]; }" & _
" else if (obj.DateHash && obj.DateHash[prop] !== undefined) { val = obj.DateHash[prop]; }" & _
" else if (obj.CheckHash && obj.CheckHash[prop] !== undefined) { val = obj.CheckHash[prop]; }" & _
" if (typeof val === 'object') { try { return JSON.stringify(val); } catch(e) { return ''; } }" & _
" return val;" & _
"}"
window.execScript jsCode, "JScript"
window.execScript "function parseJson(s) { return JSON.parse(s); }", "JScript"
On Error Resume Next
Set json = window.parseJson(jsonText)
Set dataList = json.Response.Data
On Error GoTo 0
If dataList Is Nothing Then Exit Sub
Dim i As Long, rowNum As Long
Dim item As Object
rowNum = 2
For i = 0 To window.getFieldValue(dataList, "length") - 1
Set item = CallByName(dataList, i, VbGet)
If Not item Is Nothing Then
ws.Cells(rowNum, 1).Value = window.getFieldValue(item, "ResultId")
ws.Cells(rowNum, 2).Value = window.getFieldValue(item, "Title")
ws.Cells(rowNum, 3).Value = window.getFieldValue(item, "UpdatedTime")
ws.Cells(rowNum, 4).Value = window.getFieldValue(item, "ClassC")
ws.Cells(rowNum, 5).Value = window.getFieldValue(item, "DescriptionA")
rowNum = rowNum + 1
End If
Next i
ws.Columns("A:D").AutoFit
ws.Columns("E").ColumnWidth = 60
ws.Columns("E").WrapText = True
ws.Range("A1:E" & rowNum).VerticalAlignment = xlVAlignTop
ws.Select
End Sub
'
===================================================================================
' 【ボタン2】「キーワード辞書」シート作成（初回・メンテ用）
' ===================================================================================
Sub CreateKeywordDictionarySheet()
Dim wb As Workbook
Dim ws As Worksheet
Dim sheetName As String
Set wb = ActiveWorkbook
sheetName = "キーワード辞書"
On Error Resume Next
Set ws = wb.Worksheets(sheetName)
On Error GoTo 0
If Not ws Is Nothing Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = sheetName
ws.Cells(1, 1).Value = "PMOマスタ案件名（レベル1/レベル2）"
ws.Cells(1, 2).Value = "検索キーワード（カンマ区切り）"
ws.Cells(1, 3).Value = "主な担当メンバー"
ws.Cells(1, 4).Value = "備考"
With ws.Range("A1:D1")
.Font.Bold = True
.Font.Color = RGB(255, 255, 255)
.Interior.Color = RGB(31, 78, 121)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Dim dictData As Variant
dictData = Array( _
Array("契約のグランドデザイン", "契約GD,シグマ,SX,ラモ,Lamo,FBJ,契約システム,決裁システム", "●●,●●,●●,●●", "契約GD関連"), _
Array("リーシングAIの導入PoC", "リーシングAI,CW,カウンター,Counterworks", "●●,●●,●●", "リーシングAI PoC"), _
Array("店頭一時使用（催事）", "催事,一時使用,ShopCounter,BPO", "●●,●●,●●", "催事関連"), _
Array("契約締結", "シグマ,ラモ,Lamo,本契約,覚書,PC貸与", "●●,●●", "契約締結"), _
Array("Wifi環境", "Wifi,NW,ネットワーク,ルータ,IP枯渇,ユーカリが丘,おゆみ野,福岡事務所", "●●,●●,●●,●●", "インフラ・NW"), _
Array("Members AI", "Members,メンバーズ,ポートフォリオ", "●●,●●", "AI活用"), _
Array("プリザンター研修", "プリザンター研修,Lamo研修,講義", "●●,●●", "研修"), _
Array("売上速報", "売上速報,AOC,BIZMIN,ビズミン,アルファ,核店舗", "●●,●●", "売上連携"), _
Array("売上報告", "売上報告,Zero,i-Reporter,FAX", "●●,●●,●●", "売上報告"), _
Array("ファイル共有", "ファイル共有,DirectCloud,Direct Cloud,BOX,営業規則", "●●,●●,●●,●●", "ファイル共有"), _
Array("情報セキュリティ・ITガバナンス", "セキュリティ,ITガバナンス,監査,多要素認証,MFA,アカウント台帳,脆弱性,job-gear", "●●,●●,●●", "セキュリティ・監査対応"), _
Array("デバイス管理", "iPad,iPhone,PC,端末,MDM", "●●,●●,●●,●●", "デバイス・ハード") _
)
Dim i As Long
For i = LBound(dictData) To UBound(dictData)
ws.Cells(i + 2, 1).Value = dictData(i)(0)
ws.Cells(i + 2, 2).Value = dictData(i)(1)
ws.Cells(i + 2, 3).Value = dictData(i)(2)
ws.Cells(i + 2, 4).Value = dictData(i)(3)
Next i
ws.Columns("A:D").AutoFit
ws.Columns("A").ColumnWidth = 35
ws.Columns("B").ColumnWidth = 50
ws.Columns("C").ColumnWidth = 20
ws.Columns("D").ColumnWidth = 20
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws.Range("A1:D" & lastRow).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(200, 200, 200)
End With
ws.Select
MsgBox "「キーワード辞書」シートを作成・初期化しました！", vbInformation, "2. 辞書作成完了"
End Sub
' ===================================================================================
' 【ボタン3】週指定でDXメンバごとにまとめ、日付昇順で「週報集計」シートを作成
' ===================================================================================
Sub CreateWeeklySummary()
Dim wsData As Worksheet, wsSum As Worksheet
Dim startDateStr As String
Dim startDate As Date, endDate As Date
Dim lastRow As Long, i As Long, outRow As Long
Dim itemDate As Date
Dim rawDateStr As String, dateText As String
Dim memberDict As Object, memberKey As Variant
Dim memberName As String, titleText As String, bodyText As String
Dim memberColl As Collection
Dim itemArr As Variant
' 「プリザンターデータ」または「Sheet1」を取得
On Error Resume Next
Set wsData = Worksheets("プリザンターデータ")
If wsData Is Nothing Then Set wsData = Worksheets("Sheet1")
On Error GoTo 0
If wsData Is Nothing Then
MsgBox "「プリザンターデータ」シートが見つかりません。先に①を実行してください。", vbCritical
Exit Sub
End If
Dim defaultDate As String
defaultDate = Format(Date - Weekday(Date, vbMonday) + 1, "yyyy/mm/dd")
startDateStr = InputBox("集計したい週の【開始日（月曜日）】を入力してください:", "週報集計", defaultDate)
If startDateStr = "" Then Exit Sub
If Not IsDate(startDateStr) Then
MsgBox "日付の形式が正しくありません。（例: 2026/07/13）", vbExclamation
Exit Sub
End If
startDate = CDate(startDateStr)
endDate = startDate + 6
On Error Resume Next
Set wsSum = Worksheets("週報集計")
On Error GoTo 0
If wsSum Is Nothing Then
Set wsSum = Worksheets.Add(After:=wsData)
wsSum.Name = "週報集計"
Else
wsSum.Cells.Clear
End If
wsSum.Range("A1").Value = "【週報集計】 期間: " & Format(startDate, "yyyy/mm/dd") & " ～ " & Format(endDate, "yyyy/mm/dd")
wsSum.Range("A1").Font.Size = 14
wsSum.Range("A1").Font.Bold = True
lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then
MsgBox "データが見つかりません。まずデータ読み込みを実行してください。", vbExclamation
Exit Sub
End If
Set memberDict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
titleText = Trim(wsData.Cells(i, 2).Value)
dateText = ""
If Len(titleText) >= 8 Then
rawDateStr = Right(titleText, 8)
If rawDateStr Like "########" Then
dateText = Left(rawDateStr, 4) & "/" & Mid(rawDateStr, 5, 2) & "/" & Right(rawDateStr, 2)
End If
End If
If dateText = "" Or Not IsDate(dateText) Then
dateText = Left(wsData.Cells(i, 3).Value, 10)
dateText = Replace(dateText, "-", "/")
End If
If IsDate(dateText) Then
itemDate = CDate(dateText)
If itemDate >= startDate And itemDate <= endDate Then
memberName = Trim(wsData.Cells(i, 4).Value)
If memberName = "" Then memberName = "(担当未設定)"
bodyText = wsData.Cells(i, 5).Value
If Not memberDict.Exists(memberName) Then
Set memberColl = New Collection
memberDict.Add memberName, memberColl
End If
memberDict(memberName).Add Array(Format(itemDate, "yyyy/mm/dd"), titleText, bodyText)
End If
End If
Next i
outRow = 3
If memberDict.Count = 0 Then
wsSum.Cells(outRow, 1).Value = "指定された期間内のデータはありませんでした。"
MsgBox "指定期間内のデータは見つかりませんでした。", vbInformation
Exit Sub
End If
Dim startDataRow As Long, endDataRow As Long
For Each memberKey In memberDict.keys
wsSum.Cells(outRow, 1).Value = "■ DXメンバ: " & memberKey
wsSum.Cells(outRow, 1).Font.Bold = True
wsSum.Range("A" & outRow & ":C" & outRow).Interior.Color = RGB(220, 230, 241)
outRow = outRow + 1
wsSum.Cells(outRow, 1).Value = "日付"
wsSum.Cells(outRow, 2).Value = "タイトル"
wsSum.Cells(outRow, 3).Value = "業務記録本文"
wsSum.Range("A" & outRow & ":C" & outRow).Font.Bold = True
outRow = outRow + 1
startDataRow = outRow
Set memberColl = memberDict(memberKey)
For Each itemArr In memberColl
wsSum.Cells(outRow, 1).Value = itemArr(0)
wsSum.Cells(outRow, 2).Value = itemArr(1)
wsSum.Cells(outRow, 3).Value = itemArr(2)
outRow = outRow + 1
Next itemArr
endDataRow = outRow - 1
If endDataRow >= startDataRow Then
wsSum.Sort.SortFields.Clear
wsSum.Sort.SortFields.Add key:=wsSum.Range("A" & startDataRow & ":A" & endDataRow), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsSum.Sort
.SetRange wsSum.Range("A" & startDataRow & ":C" & endDataRow)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
outRow = outRow + 1
Next memberKey
wsSum.Columns("A:B").AutoFit
wsSum.Columns("C").ColumnWidth = 60
wsSum.Columns("C").WrapText = True
wsSum.Range("A1:C" & outRow).VerticalAlignment = xlVAlignTop
wsSum.Select
MsgBox "DXメンバごとの日付順（昇順）集計が完了しました！", vbInformation, "3. 人物別集計完了"
End Sub
' ===================================================================================
' 【ボタン4】「週報集計」と辞書を参照し、「[担当] M/D 要約」を作成して「週報要約」シートへ出力
' ※文字数制限なし・補助関数不要の完結版
' ===================================================================================
Sub UpdateWeeklySummaryWithDict()
Dim wb As Workbook
Dim wsReport As Worksheet, wsDict As Worksheet, wsSummary As Worksheet
Dim lastRowReport As Long, lastRowDict As Long
Dim i As Long, j As Long
Set wb = ActiveWorkbook
On Error Resume Next
Set wsReport = wb.Worksheets("週報集計")
Set wsDict = wb.Worksheets("キーワード辞書")
On Error GoTo 0
If wsReport Is Nothing Then
MsgBox "「週報集計」シートが見つかりません。先にボタン③を実行してください。", vbCritical, "エラー"
Exit Sub
End If
If wsDict Is Nothing Then
MsgBox "「キーワード辞書」シートが見つかりません。先にボタン②を実行してください。", vbCritical, "エラー"
Exit Sub
End If
' 出力先「週報要約」シートの準備
On Error Resume Next
Set wsSummary = wb.Worksheets("週報要約")
On Error GoTo 0
If wsSummary Is Nothing Then
Set wsSummary = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
wsSummary.Name = "週報要約"
Else
wsSummary.Cells.Clear
End If
' 辞書データの読み込み
lastRowDict = wsDict.Cells(wsDict.Rows.Count, 1).End(xlUp).Row
If lastRowDict < 2 Then
MsgBox "「キーワード辞書」にデータがありません。", vbExclamation, "警告"
Exit Sub
End If
Dim projects() As String
Dim keywords() As Variant
ReDim projects(1 To lastRowDict - 1)
ReDim keywords(1 To lastRowDict - 1)
For i = 2 To lastRowDict
projects(i - 1) = Trim(wsDict.Cells(i, 1).Value)
keywords(i - 1) = Split(wsDict.Cells(i, 2).Value, ",")
Next i
' 「週報集計」シートのデータを解析
lastRowReport = wsReport.Cells(wsReport.Rows.Count, 1).End(xlUp).Row
Dim dictSummary As Object
Set dictSummary = CreateObject("Scripting.Dictionary")
Dim rawBody As String, memberName As String, shortName As String
Dim dateVal As Variant, titleVal As Variant, dateFormatted As String
Dim lines As Variant, lineItem As Variant
Dim matchedProj As String, kw As Variant
Dim dictKey As String
Dim currentMember As String: currentMember = ""
Dim pOpen As Long, pSpace As Long, kanjiPart As String
Dim cleanTitle As String, yyyymmdd As String, mVal As Long, dVal As Long
For i = 1 To lastRowReport
' メンバー名行の解析
If wsReport.Cells(i, 1).Value Like "■ DXメンバ: *" Then
currentMember = Trim(Replace(wsReport.Cells(i, 1).Value, "■ DXメンバ: ", ""))
' データ行の解析
ElseIf IsDate(wsReport.Cells(i, 1).Value) Then
dateVal = wsReport.Cells(i, 1).Value
titleVal = wsReport.Cells(i, 2).Value
rawBody = wsReport.Cells(i, 3).Value
memberName = currentMember
' --- 【内包処理】メンバー略称抽出（インライン処理） ---
shortName = memberName
pOpen = InStr(memberName, "(")
If pOpen > 0 Then
kanjiPart = Trim(Mid(memberName, pOpen + 1))
kanjiPart = Replace(kanjiPart, ")", "")
pSpace = InStr(kanjiPart, " ")
If pSpace > 0 Then
shortName = Left(kanjiPart, pSpace - 1)
Else
shortName = kanjiPart
End If
End If
' --- 【内包処理】日付整形（インライン処理） ---
dateFormatted = ""
If Not IsError(titleVal) And Not IsNull(titleVal) Then
cleanTitle = Replace(Replace(Trim(CStr(titleVal)), "-", ""), " ", "")
If Len(cleanTitle) >= 8 Then
yyyymmdd = Right(cleanTitle, 8)
If IsNumeric(yyyymmdd) Then
mVal = CLng(Mid(yyyymmdd, 5, 2))
dVal = CLng(Right(yyyymmdd, 2))
If mVal >= 1 And mVal <= 12 And dVal >= 1 And dVal <= 31 Then
dateFormatted = mVal & "/" & dVal
End If
End If
End If
End If
If dateFormatted = "" And IsDate(dateVal) Then
dateFormatted = Month(CDate(dateVal)) & "/" & Day(CDate(dateVal))
End If
' 本文解析とキーワード判定
If rawBody <> "" And rawBody <> "休日" And rawBody <> "有休休暇" Then
lines = Split(Replace(rawBody, vbCr, ""), vbLf)
For Each lineItem In lines
Dim cleanLine As String
cleanLine = Trim(Replace(lineItem, "・", ""))
If cleanLine <> "" Then
matchedProj = ""
For j = 1 To UBound(projects)
For Each kw In keywords(j)
If Trim(kw) <> "" And InStr(1, cleanLine, Trim(kw), vbTextCompare) > 0 Then
matchedProj = projects(j)
Exit For
End If
Next kw
If matchedProj <> "" Then Exit For
Next j
If matchedProj <> "" Then
dictKey = matchedProj & "||" & shortName
If Not dictSummary.Exists(dictKey) Then
dictSummary.Add dictKey, New Collection
End If
dictSummary(dictKey).Add dateFormatted & "||" & cleanLine
End If
End If
Next lineItem
End If
End If
Next i
' ヘッダーの書き出し
wsSummary.Cells(1, 1).Value = "PMOマスタ案件名"
wsSummary.Cells(1, 2).Value = "担当者"
wsSummary.Cells(1, 3).Value = "今週の要約（PMOマスタ差し込み形式）"
With wsSummary.Range("A1:C1")
.Font.Bold = True
.Font.Color = RGB(255, 255, 255)
.Interior.Color = RGB(31, 78, 121)
.HorizontalAlignment = xlCenter
End With
' --- 【文字数制限・件数制限完全撤廃の要約出力処理】 ---
Dim rowIdx As Long: rowIdx = 2
Dim key As Variant, parts As Variant
Dim projName As String, memName As String
Dim itemList As Collection
Dim uniqueTopics As Object
Dim itemIdx As Long, rawItem As String, dStr As String, contentStr As String
Dim formattedEntry As String, summarizedText As String
For Each key In dictSummary.keys
parts = Split(key, "||")
projName = parts(0)
memName = parts(1)
Set itemList = dictSummary(key)
Set uniqueTopics = CreateObject("Scripting.Dictionary")
' 対象案件の全アイテムをループログ（制限なし）
For itemIdx = 1 To itemList.Count
rawItem = itemList(itemIdx)
parts = Split(rawItem, "||")
dStr = parts(0)
contentStr = parts(1)
If dStr <> "" Then
formattedEntry = dStr & " " & contentStr
Else
formattedEntry = contentStr
End If
' 重複のみ排除して全件格納
If Not uniqueTopics.Exists(formattedEntry) Then
uniqueTopics.Add formattedEntry, True
End If
Next itemIdx
' 文字数カット（Len > 90）を行わず、すべてのトピックを「 / 」で連結
summarizedText = Join(uniqueTopics.keys, " / ")
wsSummary.Cells(rowIdx, 1).Value = projName
wsSummary.Cells(rowIdx, 2).Value = memName
wsSummary.Cells(rowIdx, 3).Value = "[" & memName & "] " & summarizedText
rowIdx = rowIdx + 1
Next key
wsSummary.Columns("A:C").AutoFit
wsSummary.Columns("C").ColumnWidth = 85
wsSummary.Columns("C").WrapText = True
With wsSummary.Range("A1:C" & rowIdx - 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(200, 200, 200)
End With
wsSummary.Select
MsgBox "「週報集計」の対象週データをもとに全件網羅の「要約」を作成しました！", vbInformation, "4. 要約作成完了"
End Sub
' ===================================================================================
' 【ボタン5】「週報要約」の結果を「PMOマスタ.xlsx」のG列へ安全に自動転記（判定強化版）
' ===================================================================================
Sub WriteSummaryToPMOMasterG()
Dim wbLocal As Workbook, wbPMO As Workbook
Dim wsSummary As Worksheet, wsPMO As Worksheet
Dim pmoPath As String
Dim lastRowSummary As Long, lastRowPMO As Long
Dim i As Long, j As Long
Set wbLocal = ActiveWorkbook
On Error Resume Next
Set wsSummary = wbLocal.Worksheets("週報要約")
On Error GoTo 0
If wsSummary Is Nothing Then
MsgBox "「週報要約」シートが見つかりません。先にボタン④を実行してください。", vbCritical
Exit Sub
End If
' --- ファイルパスの取得 ---
On Error Resume Next
If wbLocal.Path <> "" And InStr(1, wbLocal.Path, "http", vbTextCompare) = 0 Then
pmoPath = wbLocal.Path & "\PMOマスタ.xlsx"
If Dir(pmoPath) = "" Then pmoPath = ""
Else
pmoPath = ""
End If
On Error GoTo 0
If pmoPath = "" Then
Dim fileFilter As String
fileFilter = "Excel ファイル (*.xlsx; *.xlsm), *.xlsx; *.xlsm"
pmoPath = Application.GetOpenFilename(fileFilter, , "PMOマスタ（または PMOマスタ_2.xlsx）を選択してください")
If pmoPath = "False" Or pmoPath = "" Then Exit Sub
End If
' --- PMOマスタを開く ---
On Error Resume Next
Set wbPMO = Workbooks.Open(pmoPath)
On Error GoTo 0
If wbPMO Is Nothing Then
MsgBox "指定されたファイルを開くことができませんでした。", vbCritical
Exit Sub
End If
On Error Resume Next
Set wsPMO = wbPMO.Worksheets("PMO週報")
On Error GoTo 0
If wsPMO Is Nothing Then
MsgBox "選択されたファイル内に「PMO週報」シートが見つかりません。", vbCritical
wbPMO.Close SaveChanges:=False
Exit Sub
End If
lastRowSummary = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Row
lastRowPMO = wsPMO.Cells(wsPMO.Rows.Count, 2).End(xlUp).Row
Dim rawProjName As String, newComment As String
Dim cleanProj As String
Dim level1 As String, level2 As String
Dim cleanL1 As String, cleanL2 As String
Dim existingVal As String
Dim isMatched As Boolean
Dim updateCount As Long: updateCount = 0
For i = 2 To lastRowSummary
rawProjName = Trim(CStr(wsSummary.Cells(i, 1).Value))
newComment = Trim(CStr(wsSummary.Cells(i, 3).Value)) ' [担当] M/D 内容
' 比較用にスペースを全て削除した文字列を作る
cleanProj = CleanString(rawProjName)
If cleanProj <> "" And newComment <> "" Then
For j = 2 To lastRowPMO
level1 = Trim(CStr(wsPMO.Cells(j, 2).Value))
level2 = Trim(CStr(wsPMO.Cells(j, 3).Value))
cleanL1 = CleanString(level1)
cleanL2 = CleanString(level2)
isMatched = False
' --- 双方向（どちらが含まれていてもOK）で判定 ---
If cleanL2 <> "" Then
If InStr(1, cleanL2, cleanProj, vbTextCompare) > 0 Or _
InStr(1, cleanProj, cleanL2, vbTextCompare) > 0 Then
isMatched = True
End If
End If
If Not isMatched And cleanL1 <> "" Then
If InStr(1, cleanL1, cleanProj, vbTextCompare) > 0 Or _
InStr(1, cleanProj, cleanL1, vbTextCompare) > 0 Then
isMatched = True
End If
End If
' --- マッチした場合の書き込み処理 ---
If isMatched Then
existingVal = Trim(CStr(wsPMO.Cells(j, 7).Value))
If existingVal = "" Then
' 1. 空白なら新規書き込み
wsPMO.Cells(j, 7).Value = newComment
updateCount = updateCount + 1
Else
' 2. 既存データがあり、未追記テキストなら改行（vbCrLf）を入れて末尾に追記
If InStr(1, existingVal, newComment, vbTextCompare) = 0 Then
wsPMO.Cells(j, 7).Value = existingVal & vbCrLf & newComment
updateCount = updateCount + 1
End If
End If
End If
Next j
End If
Next i
wbPMO.Save
MsgBox "「PMOマスタ」のG列へ " & updateCount & " 件のコメントを更新・追記しました！", vbInformation, "5. 転記完了"
End Sub
' --- 補助関数：文字列からスペースや改行を除去して純粋な比較用文字列を作る ---
Private Function CleanString(ByVal txt As String) As String
txt = Replace(txt, " ", "")
txt = Replace(txt, " ", "")
txt = Replace(txt, vbCr, "")
txt = Replace(txt, vbLf, "")
CleanString = txt
End Function
4. 実際に運用してみて分かった課題（フィードバック）
「業務記録 ➔ PMOマスタ（Excel）」への自動転記が完成したため、さっそくメンバーに仮入力の有効性をヒアリングを実施しました。
メンバーからの声
- 「文字が途中で切れている」
➔ 最初の設定は90文字以上は省略するコードになっていました。そこで全文転記するように改修！
（文字が省略されていた理由のコード）
上記の課題を解決するために全文を載せてみることにしました。すると次は、
- 「…文字が長すぎて結局何書いているかわからない」
➔ たしかにその通りなんです。ということで、この内容を要約して転記する方法へ改修！（しようと思いました。）
5. 次のステップ（課題）
単純転記では情報量が多すぎるため、「生成AIのAPIと連携して100文字程度に要約してから転記する」 機能の追加を試みました。
しかし、API呼び出し時のエラーが出て、その回避が今回の時間内に間に合わず．．．
（エラー画面）
💡 まとめと今後の展望
今回は一旦ここまでとし、次回「LLM要約連携編」としてリベンジしたいと思います！
また、時間の関係上キーワード辞書についても、まだ全部の案件のキーワードを入力しきれていません...
実際の実用にはもう少しいろいろな下準備をしていく必要があります。
まずは第一歩として、日々の業務記録をExcel週報へ集約する流れを作ることができました。
「LLM要約機能」や「PowerPoint連携」へチャレンジして続編を投稿します。