質問58753 このコードでうまく動作しません。どうしたら良いですか Private Sub Wor

質問58753
このコードでうまく動作しません。どうしたら良いですか

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim mapping As Object
Dim targetCell As Range
Dim currentValue As String, prefix As String
Dim cell As Range

' シートを指定（適宜変更）
Set ws = ThisWorkbook.Sheets("Sheet1")

' DセルとBセルの対応関係
Set mapping = CreateObject("Scripting.Dictionary")
mapping.Add "D3", "B80"
mapping.Add "D4", "B82"
mapping.Add "D6", "B85"
mapping.Add "D8", "B87"
mapping.Add "D12", "B90"
mapping.Add "D21", "B92"
mapping.Add "D25", "B94"
mapping.Add "D29", "B96"
mapping.Add "D31", "B98"
mapping.Add "D1", "B100"
mapping.Add "D2", "B102"
mapping.Add "D9", "B104"
mapping.Add "D11", "B106"
mapping.Add "D33", "B108"

' 変更されたセルが D1:D33 以外の場合は処理しない
If Intersect(Target, ws.Range("D1:D33")) Is Nothing Then Exit Sub

' 変更されたセルが複数ある場合は処理しない（Ctrl + V でも動作するが安全策）
If Target.Cells.Count > 1 Then Exit Sub

On Error GoTo ErrorHandler ' エラーハンドリング開始
Application.EnableEvents = False

' ① 指定セルが空白なら色を付ける
Dim rngYellow As Variant, rngBlue As Variant, rngGreen As Variant
rngYellow = Array("D3", "D4", "D6", "D8", "D12")
rngBlue = Array("D1", "D2", "D9", "D11", "D33")
rngGreen = Array("D21", "D25", "D29", "D31")

' 黄色のセル（D3, D4, D6, D8, D12）
For Each cell In rngYellow
If ws.Range(cell).Value = "" Then
ws.Range(cell).Interior.Color = RGB(255, 255, 0) ' 黄色
Else
ws.Range(cell).Interior.ColorIndex = xlNone ' 色リセット
End If
Next cell

' 青色のセル（D1, D2, D9, D11, D33）
For Each cell In rngBlue
If ws.Range(cell).Value = "" Then
ws.Range(cell).Interior.Color = RGB(0, 0, 255) ' 青色
Else
ws.Range(cell).Interior.ColorIndex = xlNone ' 色リセット
End If
Next cell

' 緑色のセル（D21, D25, D29, D31）
For Each cell In rngGreen
If ws.Range(cell).Value = "" Then
ws.Range(cell).Interior.Color = RGB(0, 255, 0) ' 緑色
Else
ws.Range(cell).Interior.ColorIndex = xlNone ' 色リセット
End If
Next cell

' ② Bセルの「:」の後ろにDセルの値をセット
If mapping.exists(Target.Address(False, False)) Then
Set targetCell = ws.Range(mapping(Target.Address(False, False)))
currentValue = targetCell.Value

' 「:」の位置を探す
If InStr(currentValue, ":") > 0 Then
prefix = Left(currentValue, InStr(currentValue, ":")) ' 「:」までの部分を取得

If Target.Value = "" Then
' Dセルが空なら「:」の後ろを消去
targetCell.Value = prefix
Else
' Dセルに値がある場合は「:」の後ろに値をセット
targetCell.Value = prefix & " " & Target.Value
End If
Else
' 万が一「:」がない場合の処理
If Target.Value = "" Then
targetCell.Value = ""
Else
targetCell.Value = Target.Value
End If
End If
End If

' ③ 貼り付け時の書式設定
For Each cell In Target
' フォント設定（UDPゴシックが存在する場合のみ適用）
On Error Resume Next
cell.Font.Name = "UDPゴシック"
On Error GoTo 0 ' フォントが存在しない場合のエラーを無視して続行

' セルの格子線をつける
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With

' 中央揃え（水平 & 垂直）
cell.HorizontalAlignment = xlCenter
cell.VerticalAlignment = xlCenter
Next cell

ExitHandler:
Application.EnableEvents = True
Exit Sub

ErrorHandler:
' エラーが発生した場合、イベントを有効に戻して終了
MsgBox "エラーが発生しました：" & Err.Description, vbExclamation, "エラー"
Resume ExitHandler
End Sub

No.5 回答者： どちてオジサン 回答日時： 2025/01/30 12:27

ChatGPTにでも訊けよ。

No.4 回答者： Qchan1962 回答日時： 2025/01/30 11:19

されたい事は分からないけれど・・・

コードを読んで明らかに違うと思う事です

rngYellow = Array("D3", "D4", "D6", "D8", "D12")
rngBlue = Array("D1", "D2", "D9", "D11", "D33")
rngGreen = Array("D21", "D25", "D29", "D31")

For Each cell In

Dim cell As Range

変数　cellは　RangeObjectではないです
Stringになりますが・・・For EachなのでVariantとしなくてはなりません

Dim cell As Variant
に変更してみてください

さらなる問題があるかも知れませんがとりあえず

No.3 回答者： satoumasaru 回答日時： 2025/01/30 09:21

そもそも、このコードは何をするものなのか

どこでどのようなエラーがでるのか
それにどのように対処したのか

このあたりが明確にならないと誰も答えられないですよ。

No.2 回答者： hinso_0222 回答日時： 2025/01/30 08:53

デバッグして動くように修正すれば良いです。

No.1 回答者： いんちょ 回答日時： 2025/01/30 08:52

エラーが出るようでしたらデバッグモードに入りエラー箇所に記載間違いが無いか確認してください。