空白のセルの場合は同じ文字を入力するＶＢＡ

質問

(1)セルＬ５・Ｌ６・Ｌ２３・Ｌ２４・Ｌ２５があります。

上記で述べたセル範囲の文字が空白表示の場合、上記範囲の何処かに文字を入力したら、入力した文字と一緒の文字が自動で入力させます。（例えばＬ２４に「１」と入力した場合はＬ５・Ｌ６・Ｌ２４・Ｌ２５に「１」と自動で入力）

そして上記で述べたセル範囲の何処か１つでも文字が入っていると、文字が自動で入力されない（例えばＬ５に「３」と入力されている状態でＬ２５に「８」と入力してもＬ６・Ｌ２３・Ｌ２４の文字は何も変化しない）ＶＢＡはどの様にすれば良いでしょうか？

(2)セルＭ５・Ｍ６・Ｍ２３・Ｍ２４・Ｍ２５があります。

上記で述べたセル範囲の文字が空白表示の場合、上記範囲の何処かに文字を入力したら、入力した文字と一緒の文字が自動で入力させます。（例えばＭ２４に「１」と入力した場合はＭ５・Ｍ６・Ｍ２４・Ｍ２５に「１」と自動で入力）

そして上記で述べたセル範囲の何処か１つでも文字が入っていると、文字が自動で入力されない（例えばＭ５に「３」と入力されている状態でＭ２５に「８」と入力してもＭ６・Ｍ２３・Ｍ２４の文字は何も変化しない）ＶＢＡはどの様にすれば良いでしょうか？

(3)セルＬ８～Ｌ１０の範囲があります。

上記で述べたセル範囲の文字が空白表示の場合、上記範囲の何処かに文字を入力したら、文字が自動で入力させます。（例えばＬ９に「１」と入力した場合はＬ８・Ｌ１０に「１」と自動で入力）

上記で述べたセル範囲の何処かに既に文字が入っていると、文字が自動で入力されない（例えばＬ１０に「３」と入力されている状態でＬ８に「８」と入力してもＬ９の文字は何も変化しない）ＶＢＡはどの様にすれば良いでしょうか？

回答No.1

eden3616 · ベストアンサー

(1)シート名のタブ(左下にある切替用のタブ)を右クリック
(2)「コードの表示」を選択して下記のVBAコードを貼付
(3)右上の×または、Alt+F11でVBEを終了
(4)該当のセル範囲に値を入力すると処理が実行されます

・コード内の末尾「★」の場所で対象とするセル範囲を変更できます
・コピペなどによる複数セルの同時変更には対応していません

また、以下の二点の確認があります。

>(1)セルＬ５・Ｌ６・Ｌ２３・Ｌ２４・Ｌ２５
>（例えばＬ２４に「１」と入力した場合はＬ５・Ｌ６・Ｌ２４・Ｌ２５に「１」と自動で入力）
　Ｌ２４ではなく、Ｌ２３ですよね？

>(2)セルＭ５・Ｍ６・Ｍ２３・Ｍ２４・Ｍ２５
>（例えばＭ２４に「１」と入力した場合はＭ５・Ｍ６・Ｍ２４・Ｍ２５に「１」と自動で入力）
　Ｍ２４ではなく、Ｍ２３ですよね？

■VBAコード

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
'準備
Dim flag As Boolean, ckCells As Variant, ckCell As Variant, myTar As Range
Application.EnableEvents = False
Application.ScreenUpdating = False

'判定(1)
ckCells = Array("L5", "L6", "L23:L25") '★
Set myTar = Nothing
For Each ckCell In ckCells
　　If myTar Is Nothing Then
　　　　Set myTar = Range(ckCell)
　　Else
　　　　Set myTar = Union(myTar, Range(ckCell))
　　End If
　　If Not Application.Intersect(Target, Range(ckCell)) Is Nothing Then flag = True
Next
If flag Then GoTo go

'判定(2)
ckCells = Array("M5", "M6", "M23:M25") '★
Set myTar = Nothing
For Each ckCell In ckCells
　　If myTar Is Nothing Then
　　　　Set myTar = Range(ckCell)
　　Else
　　　　Set myTar = Union(myTar, Range(ckCell))
　　End If
　　If Not Application.Intersect(Target, Range(ckCell)) Is Nothing Then flag = True
Next
If flag Then GoTo go

'判定(3)
ckCells = Array("L8:L10") '★
Set myTar = Nothing
For Each ckCell In ckCells
　　If myTar Is Nothing Then
　　　　Set myTar = Range(ckCell)
　　Else
　　　　Set myTar = Union(myTar, Range(ckCell))
　　End If
　　If Not Application.Intersect(Target, Range(ckCell)) Is Nothing Then flag = True
Next

go:
'変更適用
If flag Then
　　If WorksheetFunction.CountA(myTar) = 1 Then
　　　　If Len(Target) > 0 Then myTar = Target
　　End If
End If

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

お礼

質問内容を少し間違えてスイマセン、ご指摘の通りです。
この度はありがとうございます！！非常に助かりました。