【Excel VBA】空白の結合セルに右上り斜線を引く

質問

Excel VBAは初心者です。
仕事で必要なため、アドバイスをいただけると非常に助かります。
よろしくお願いします。

【VBAで実現したいこと】
　下記のようなセルで構成されている簡単な
　申請書を作成しております。

　結合セル1：ABCD列と4行目で結合されたセルで、氏名を入力します。
　結合セル2：EFGH列と4行目で結合されたセルで、氏名を入力します。
　結合セルA：ABCD列から5678行で結合されたセルです。
　結合セルB：EFGH列から5678行で結合されたセルです。
　※結合セル1、2～10まで存在し、結合セルA、B～Jまで存在します。

　結合セルAは結合セル1を参照し、結合セル1が空欄の場合
　結合セルAに右上りの斜線を引きます。結合セル1が空欄でない場合、
　何もしません。

　結合セルBは結合セル2を参照し、結合セル2が空欄の場合
　結合セルBに右上りの斜線を引きます。結合セル2が空欄でない場合、
　何もしません。
　同様な処理を、結合セルJ、結合セル10まで行います。

【教えていただきたいこと】
　1.結合セルA～J、結合セル1～10全てが空欄だった場合、
　　空欄の結合セルは右上りの斜線を引きます。
　　下記のプログラムを作成しましたが、右上りの斜線が
　　引けません。
　　どのようにしたら良いでしょうか。

　2.上記「VBAで実現したいこと」を行うためには、
　　下記のプログラムにどのような追加を行えば良いでしょうか。

【作成したプログラム】
Private Sub worksheet_change(ByVal target As Range)
Dim i As Range
For Each i In target
If i.MergeArea.Value = "" Then
i.MergeArea.Borders(xlDiagonalUp).LineStyle = xlContinuous
Else
i.MergeArea.Borders(xlDiagonalUp).LineStyle = xlNone
End If
Next i
End Sub

以上、よろしくお願いします。

回答No.2

merlionXX · ベストアンサー

> 色々試してみましたが、やはりmerlionXXさんの添付画像のような結果になりませんでした。

ではどういう結果になったのですか？
もしまったく作動しないのなら、マクロはどこに書きましたか？
ひょっとしてシートモジュールではなく標準モジュールに書いてませんか？

お礼

merlionXXさん、フォローありがとうございます。

僕は「ThisWorkbook」に書いておりました。
merlionXXさんが教えてくれたとおり「sheet1」に書くことで無事に対応できました。

画像で示していただき、初心者の僕でも理解し易かったです。
merlionXXさんありがとうございました。

回答No.5

cj_mover

＃３、４です。何度もすみません。訂正です。

　＞そのままではVBAで扱えない関数なので、
　＞.EVALUATE メソッドに文字列式を渡し、
WorksheetFunction で扱えますので、この記述は誤りでした。
なので、動作は同じですが、
誤）
　　　　If Evaluate("PHONETIC(" & TAISYOUHANNI & ")") = "" Then
正）
　　　　If WorksheetFunction.Phonetic(.Cells) = "" Then

以上、修正をお願いします。

お礼

cj_moverさん、回答ありがとうございます。

cj_moverさんから教示いただいたプログラムにて
対応ができました。

また、早急な修正フォローも助かりました。
ありがとうございました。

回答No.4

cj_mover

＃３です
"追加"の意味を考えました。判別方法は色々あるけど
手っ取り早くワークシート関数のPHONETIC()を使ってみます。
そのままではVBAで扱えない関数なので、
.EVALUATE メソッドに文字列式を渡し、
Worksheet オブジェクトに文字列式の評価を問い合わせ
戻り値が "" かどうかで判定します。
要するに TAISYOUHANNI に（ふりがな情報を持つ）文字列セルがない場合、
と、それ以外とを判別します。

Private Sub Worksheet_Change(ByVal Target As Range)
Const TAISYOUHANNI = "A4:AN4"
　　If Intersect(Range(TAISYOUHANNI), Target) Is Nothing Then Exit Sub
Dim oRng As Range
　　For Each oRng In Intersect(Range(TAISYOUHANNI), Target)
　　　　If oRng.MergeCells Then
　　　　　　If oRng.MergeArea.Column = oRng.Column Then
　　　　　　　　With oRng.Offset(1).MergeArea
　　　　　　　　　　If oRng.Value = "" Then
　　　　　　　　　　　　.Borders(xlDiagonalUp).LineStyle = xlContinuous
　　　　　　　　　　Else
　　　　　　　　　　　　.Borders(xlDiagonalUp).LineStyle = xlNone
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　End If
　　　　End If
　　Next oRng
　　With Range(TAISYOUHANNI)
　　　　If Evaluate("PHONETIC(" & TAISYOUHANNI & ")") = "" Then
　　　　　　.Borders(xlDiagonalUp).LineStyle = xlContinuous
　　　　Else
　　　　　　.Borders(xlDiagonalUp).LineStyle = xlNone
　　　　End If
　　End With
End Sub

回答No.3

cj_mover

こんにちは。

＃条件付書式で出来るようにしてくれればいいのにねぇ。
＃なんで囲みだけにしか対応してないいんだろー。

書いてみたので試してみてください。
　「全セル」、
　「単一ではないセル範囲」、
　「複数領域を持つセル範囲」、
　「【結合セル１－１０】を内包するセル範囲」、
について、
　「値入力」
　「値消去」
した場合について、一応の動作確認はしましたが、
まだ漏れはあるかもしれませんがメンテはお任せします。

契機にする対象範囲を、定数 TAISYOUHANNI で文字列指定するようにしました。
処理対象範囲は .Offset(1).MergeArea にしましたので、
MergeArea の列数には依存せず、変更も比較的簡単かと思います。
契機にする対象は MergeArea の一番左のセルだけです。
ちょっと工夫すれば MergeArea の行数に依存しないようにもできるでしょう。

Private Sub Worksheet_Change(ByVal Target As Range)
Const TAISYOUHANNI = "A4:AN4"
　　If Intersect(Range(TAISYOUHANNI), Target) Is Nothing Then Exit Sub
Dim oRng As Range
　　For Each oRng In Intersect(Range(TAISYOUHANNI), Target)
　　　　If oRng.MergeCells Then
　　　　　　If oRng.MergeArea.Column = oRng.Column Then
　　　　　　　　With oRng.Offset(1).MergeArea
　　　　　　　　　　If oRng.Value = "" Then
　　　　　　　　　　　　.Borders(xlDiagonalUp).LineStyle = xlContinuous
　　　　　　　　　　Else
　　　　　　　　　　　　.Borders(xlDiagonalUp).LineStyle = xlNone
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　End If
　　　　End If
　　Next
End Sub

回答No.1

merlionXX

質問を誤解しているかもしれませんが、以下のようなことでしょうか？

４行目は1行４列で結合したセルが右に10個（AN列まで）並んでいる。
５から8行目は4行４列で結合したセルが右に10個（AN列まで）並んでいる。
５から8行目の結合セルは、その上の4行目の結合セルを参照する式が入っている。
4行目が空白ならその下の結合セルには何も表示されない。（=""　となる）
4行目の空白セルと下の何も表示されない結合セルすべてに斜線を自動的に表示させたい。

以下を試してみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Range, myRng As Range
　　Set myRng = Range("A4:AN8")
　　If Intersect(Target, myRng) Is Nothing Then Exit Sub
　　For Each i In myRng
　　　　If i.MergeArea(1).Text = "" Then
　　　　　　i.MergeArea.Borders(xlDiagonalUp).LineStyle = xlContinuous
　　　　Else
　　　　　　i.MergeArea.Borders(xlDiagonalUp).LineStyle = xlNone
　　　　End If
　　Next i
End Sub

補足

merlionXXさん、回答いただきありがとうございます。

>質問を誤解しているかもしれませんが、以下のようなことでしょうか？
⇒merlionXXさんの認識であっております。

>以下を試してみてください。
⇒merlionXXさんの添付画像のような結果になりませんでした。
　空白セル時を参照しても、空白で無いセルを参照しても、
　斜線は引かれずそのままでした。

色々試してみましたが、やはりmerlionXXさんの添付画像のような結果になりませんでした。

僕なりに原因を引き続き調べてみますが、もし原因がわかりましたら、
教示いただけると助かります。