| エクセル | の学校 |
| 8.一覧 | 9.HOME |
| 1.Top | 2.Last |
『動作しません』（ニック）
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B1,A2:F31,H1:H2")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim wsIn As Worksheet: Set wsIn = Me
Dim wsOut As Worksheet: Set wsOut = Worksheets("集計")
Dim baseDate As Date
If wsIn.Range("B1").Value = "" Then GoTo ExitHandler
baseDate = wsIn.Range("B1").Value
'===========================
' 日付・曜日自動生成
'===========================
Dim lastDay As Long, i As Long
lastDay = Day(DateSerial(Year(baseDate), Month(baseDate) + 1, 0))
Range("A2:B31,D2:E31").ClearContents
For i = 1 To lastDay
If i <= 17 Then
Cells(i + 1, 1).Value = i
Cells(i + 1, 2).Value = Format(DateSerial(Year(baseDate), Month(baseDate), i), "aaa")
Else
Cells(i - 16 + 1, 4).Value = i
Cells(i - 16 + 1, 5).Value = Format(DateSerial(Year(baseDate), Month(baseDate), i), "aaa")
End If
Next i
'===========================
' 重み取得
'===========================
Dim weightYear As Double: weightYear = wsIn.Range("H1").Value / 100
Dim weightMonth As Double: weightMonth = wsIn.Range("H2").Value / 100
'===========================
' 月回数集計（個人単位）
'===========================
Dim inData As Variant: inData = wsIn.Range("C2:F31").Value
Dim monthDict As Object: Set monthDict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(inData)
If inData(i, 1) <> "" Then monthDict(inData(i, 1)) = monthDict(inData(i, 1)) + 1
If inData(i, 4) <> "" Then monthDict(inData(i, 4)) = monthDict(inData(i, 4)) + 1
Next i
'===========================
' 出力取得
'===========================
Dim lastRow As Long: lastRow = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then GoTo ExitHandler
Dim outData As Variant: outData = wsOut.Range("A2:H" & lastRow).Value
Dim resultArr(): ReDim resultArr(1 To UBound(outData), 1 To 6)
Dim groupMonthTotal As Object: Set groupMonthTotal = CreateObject("Scripting.Dictionary")
Dim groupYearTotal As Object: Set groupYearTotal = CreateObject("Scripting.Dictionary")
Dim groupCount As Object: Set groupCount = CreateObject("Scripting.Dictionary")
Dim groupName As String, memberName As String
' 月回数・グループ人数計算
For i = 1 To UBound(outData)
groupName = outData(i, 1)
memberName = outData(i, 2)
resultArr(i, 1) = IIf(monthDict.exists(memberName), monthDict(memberName), 0)
groupMonthTotal(groupName) = groupMonthTotal(groupName) + resultArr(i, 1)
groupCount(groupName) = groupCount(groupName) + 1
Next i
' 年回数累積管理（翌年1月自動リセット）
For i = 1 To UBound(outData)
groupName = outData(i, 1)
If Month(baseDate) = 1 And wsOut.Cells(i + 1, 5).Value <> "" Then
resultArr(i, 3) = resultArr(i, 1) ' 新年は前年累積リセット
Else
resultArr(i, 3) = IIf(IsNumeric(wsOut.Cells(i + 1, 5).Value), wsOut.Cells(i + 1, 5).Value, 0) + resultArr(i, 1)
End If
groupYearTotal(groupName) = groupYearTotal(groupName) + resultArr(i, 3)
Next i
' 月全体・年全体・負担率計算
For i = 1 To UBound(outData)
groupName = outData(i, 1)
resultArr(i, 2) = groupMonthTotal(groupName) ' 月全体
resultArr(i, 4) = groupYearTotal(groupName) ' 年全体
Dim avgMonth As Double, avgYear As Double
avgMonth = groupMonthTotal(groupName) / groupCount(groupName)
avgYear = groupYearTotal(groupName) / groupCount(groupName)
resultArr(i, 5) = (resultArr(i, 3) - avgYear) * weightYear + _
(resultArr(i, 1) - avgMonth) * weightMonth
Next i
' 出力書き戻し
For i = 1 To UBound(outData)
wsOut.Cells(i + 1, 3).Resize(1, 5).Value = Array(resultArr(i, 1), resultArr(i, 2), resultArr(i, 3), resultArr(i, 4), resultArr(i, 5))
Next i
'===========================
' ★候補判定（班ごと最少負担）
'===========================
Dim starArr(): ReDim starArr(1 To UBound(outData), 1 To 1)
Dim groups As Variant: groups = Array("1班", "2班", "3班")
Dim j As Long, minScore As Double
For j = LBound(groups) To UBound(groups)
groupName = groups(j)
minScore = 999999
' 最小負担率探索
For i = 1 To UBound(outData)
If outData(i, 1) = groupName Then
If resultArr(i, 5) < minScore Then minScore = resultArr(i, 5)
End If
Next i
' ★付与（班ごと1人）
For i = 1 To UBound(outData)
If outData(i, 1) = groupName Then
If resultArr(i, 5) = minScore Then
starArr(i, 1) = "★"
Exit For
Else
starArr(i, 1) = ""
End If
End If
Next i
Next j
wsOut.Range("H2:H" & lastRow).Value = starArr
ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sud こちらを実行するとこちらが表示 入力シート（シート名：入力） 🔹 上部設定エリア セル 内容 入力 B1 対象年月 2026/04/01 など H1 年優先％ 50 H2 月優先％ 50 🔹 勤務入力エリア A列 B列 C列 D列 E列 F列 日付 曜日 メンバー 日付 曜日 メンバー 1 火 山田 18 金 佐藤 2 水 田中 19 土 山田 3 木 鈴木 20 日 高橋 … … … … … … 🔹 動作
📤 出力シート（シート名：集計） 🔹 固定構造（3班固定） A列 B列 C列 D列 E列 F列 G列 H列 班 メンバー 月回数 月全体 年回数 年全体 負担率 候補 🔹 例（表示イメージ） 班 メンバー 月回数 月全体 年回数 年全体 負担率 候補 1班 山田 2 5 8 20 -0.5 ★ 1班 田中 1 5 6 20 0.3 1班 鈴木 2 5 6 20 0.2 2班 佐藤 1 3 4 10 -0.4 ★ 2班 高橋 2 3 6 10 0.4 3班 松本 0 2 3 6 -0.6 ★ 3班 小林 2 2 3 6 0.6 📊 計算ロジック ■ 月回数 入力シートC/F列の回数を個人ごと集計 ■ 月全体 同じ班の月回数合計 ■ 年回数 前年からの累積 ※ 1月になると自動リセット ■ 年全体 班ごとの年累計合計 ■ 負担率（班内均等化）
(個人年回数 − 班平均年回数) × 年重み + (個人月回数 − 班平均月回数) × 月重み
■ 候補★ 各班で 負担率が最小の人に★
このようにしたいのですが、プログラムが動作しません。 何をすれば動作しますか？ 修正箇所をvbaコードで説明してほしいです。
＜ 使用 Excel：unknown、使用 OS：unknown ＞
■２ 上記とも関連しますが、「プログラムが動作しません。」とは、どういう状態ことを言ってますか？ 例えば、↓のようにしているのですから、該当セル以外の書き換えなら、正しく【即終了】しているだけでしょう。
If Intersect(Target, Range("B1,A2:F31,H1:H2")) Is Nothing Then Exit Sub
実行環境（データ）は、あなたの手元にしかないのですから、〇〇を疑ってみたけど△△だったとか、確認したことを共有されないとゴールが遠くなると思います
（もこな２） 2026/03/05(木) 00:12:19
If Intersect(Target, Range("B1,A2:F31,H1:H2")) Is Nothing Then Exit Sub
↓の１行目は、そのまま２行目などで無限再帰にならないように措置したからかと思いますが、はじめからB1セルだけに限定すればよいのではないですか？
Application.EnableEvents = False
Range("A2:B31,D2:E31").ClearContents
（もこな２） 2026/03/05(木) 00:26:46
（もこな２） 2026/03/05(木) 00:31:06
生成AIの回答を最初からよく読んでみてはどうですか？ 動作のさせ方が解説されてあるはず。
それはイベントプロシージャと言う特別のものなので、どこかからユーザーが命令を出すのではなく、 ・対象となっているシートのシートモジュールにコードをコピーしたうえで、 ・どこかのセルに変更を加えれば、それを察知して自動的に動作する というものです。
生成AIが作成者なんだろうから、生成AIに端的に質問を投げかければいい。 「動かないんですけど、どうやったら動くのかな？」とか。 質問は何度でもしつこく聞けばいい。 相手は人間じゃないから恥ずかしくもない。 （xyz） 2026/03/05(木) 07:01:06
私はVBA好きじゃないので使えるバージョンならpy関数をおすすめします。 やりたいことを読む限りは集計するだけなのでpy関数で対応できます。 Lambda関数と違ってループ処理を書く必要はは有りません(宣伝) めんどくさいアルゴリズムもパッケージ化されています
余計なおせっかいをすると これホントにシートチェンジで動かす気ですか？ こういうのを最適化問題っていうんですけど一意の結果を得られないのでセルが変更されると結果変わりますよ
geminiもcopilotもメジャー言語(javascript,python,poweshell)ならかなり精度よく教えてくれるので VBAと違ってファイル出力がローカル保存できないのでひと手間かかるんですけど Office Scriptっていうのをおすすめします(布教)
geminiにそのまま放り込んでレビュー geminiはマイナー言語(VBAとか)はメジャー言語の仕様を参考にして回答するので違う可能性が高いです。 ```gemini回答 ニックさん、コードを拝見しました。 動かない主な原因は、 **コード末尾の誤字（End Sud** と、 # そもそも閉じてないからコンパイルエラー
**ループ内でのシート操作によるイベントの連鎖（無 限ループに近い状態）** です。 # このイベントでシート操作→シートチェンジイベントがトリガーということらしい # さすがにシートチェンジイベントのオブジェクト内の動作でシートチェンジイベントが動くとかないと思います
また、Worksheet_Changeは「変更されたセル」をトリガーにするため、 日付の自動生成と集計処理を整理しないと意図しないタイミングで上書きが発生します。 修正したコードは以下の通りです。(略) ```
（ちくわ） 2026/03/05(木) 10:24:09
]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.