エクセルのマクロについて

質問

エクセルのマクロについて
エクセル2007を使用しています。もしよかったら教えて頂きたいと思っております。

現在利用しているメインシート(Sheet16で認識)のD5:I500の範囲内で1～31範囲の数字がランダムに入力されています。
この数字群の入ったセルをルール化しているセル背景色塗りを自動で処理したいためマクロを作成しております。
その仕様として、10個のシート（シート名：Aセット配色～Jセット配色）を作成して、各シートのB3:H7範囲に1～31までの数字が入っており、それぞれ数字に背景配色しています。Sheet16内と数字と条件によって該当する10個のシート内（シート名：Aセット配色～Jセット配色）の中から1つのシートとが一致したらそのセット配色シートのセルそのものの書式も運んでくれるルール設計になっています。
（※Sheet16の上記記載している範囲に直接入力及びコピーをして数字が一致したら、色が変わる仕組みになっています。）

更に、Sheet16内のJ3セルにA～J迄の半角英字を入力規制セットしており、例えばそのセルにCを入力すればCセット配色（シート名）、A入力であればAセット配色（シート名）を見に行き、該当処理をして行くという仕様になっております。

そのマクロ（※げＮSheet16内に作成しています）が下記なのですが、拝見頂いて仕様がすぐお分かりになると思いますが、、

Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant, c As Range, s As Range, myStr As String
Dim rng As Range

Set rng = Intersect(Target, Range("D5:I500"))
If rng Is Nothing Then Exit Sub

If Range("J3").Value = "" Then
MsgBox "セット配色が未設定です。", vbCritical, "セットエラー "
Exit Sub
End If

myStr = Range("J3").Value & "セット配色"

Application.ScreenUpdating = False
For Each c In rng.Cells
For Each s In Worksheets(myStr).Range("B3:H7")
v = c.Value
If Not IsNumeric(v) Or v < 1 Or v > 31 Then Exit For
c.Interior.ColorIndex = xlColorIndexNone
c.Font.ColorIndex = xlColorIndexAutomatic
If s.Value = v Then
c.Interior.ColorIndex = s.Interior.ColorIndex
c.Font.ColorIndex = s.Font.ColorIndex
Exit For
End If
Next s
Next c
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

今回の質問内容は、このマクロを少し仕様変更して、

C4：C500範囲でデータ書換えがあった場合にその瞬間、現行のJ3セルにその入力した英字と同じ値を表示させ次の処理に移行する方法にて上手くいかないかなと思っております。

上記のマクロを使用して追加組み込みをする前提で考えると、どういうコードを追加すれば実現出来ますでしょうか？

どうかご伝授頂けますと幸いです。

よろしくお願い申しあげます。

回答No.4

Wendy02 · ベストアンサー

こんばんは。

失礼な書き方をしたにも関わらず、丁寧な返事をつけてありがとうございます。
私は、その内容のイメージ化ができないと、あまり回答のコードは書けないのです。

今回のお返事で、どこまで理解しているかは、コードで示します。結局、掲示板の回答でも、質問によっては、本気で掛からなくては、解決しないようですね。間に合わせではダメだということのようです。

'-------------------------------------------
まとめると、セット配色の自動切り替えということと、J3 に代入するということだと思います。
補足を読んでみたら、最初の質問内容からは誤解していた部分があり、勘違いしていました。

オリジナリティは残していますが、一部変えたところがあります。
二つの要素をひとつのコードの中に入れていますが、基本的条件が変わりますので、ややこしいです。C列は、セット配色を入れるために、代入値は複数のセルに貼付けはしないけれども、数値を入れる側は、複数セルにも貼付けもあると読みました。

若干、J3に代入する値の方法が、これで良いのか不安が残ります。

コメントブロックの部分は、不要なら削除してしまってください。一応、不具合の可能性やオリジナリティのために残しています。

>　MsgBox "入力値はAからJの範囲です。", vbExclamation, "シート名エラー "

IMEの問題だと思いますが、うっかりして違った文字が入力されるとエラーは発生します。そこで、マウスで解除するのが面倒なので、Win32APIで、自動解除するように工夫しました。

MessageBoxTimeoutA　の所にある 2000 は、2秒という意味です。3 秒なら、3000 となります。

'-------------------------------------------
'Option Explicit
'以下のFunction は、必ずモジュールの上部に入れること
Private Declare Function MessageBoxTimeoutA Lib "user32" (ByVal hWnd As Long, _
　　ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal _
　　wLanguageId As Long, ByVal dwMilliseconds As Long) As Long

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim v As Variant, c As Range, s As Range, mySh As Worksheet
　　Dim rng As Range
　　'　　If Range("J3").Value = "" Then
　　'　　　　MsgBox "J3のセット配色が未設定です。", vbCritical, "セットエラー "
　　'　　　　Exit Sub
　　'　　End If
　　If Target.Count = 1 Then
　　If Target.Value = "" Then Exit Sub
　　　　If Target.Column = 3 And 3 < Target.Row And Target.Row < 501 Then 'C4:C500
　　　　　　If Not StrConv(Target.Value, vbUpperCase) Like "[A-J]" Then
　　　　　　　　MessageBoxTimeoutA 0&, "入力値はAからJの範囲です。", _
　　　　　　　　"シート名エラー ", vbMsgBoxSetForeground + vbCritical, 0, 2000
　　　　　　　　'MsgBox "入力値はAからJの範囲です。", vbExclamation, "シート名エラー "
　　　　　　　　Target.ClearContents
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　Application.EnableEvents = False
　　　　　　　　Range("J3").Value = StrConv(Target.Value, vbUpperCase) 'J3に代入
　　　　　　　　Application.EnableEvents = True
　　　　　　End If
　　　　End If
　　End If
　　On Error Resume Next
　　Set mySh = Worksheets(Range("J3").Value & "セット配色")
　　On Error GoTo 0

　　If mySh Is Nothing Then
　　　　MessageBoxTimeoutA 0&, "セット配色シートが設定されていません。", _
　　　　 "セット配色エラー", vbMsgBoxSetForeground + vbCritical, 0, 2000
　　　　'MsgBox "セット配色シートが設定されていません。", vbCritical, "セット配色エラー"
　　　　Exit Sub
　　End If
　　'範囲限定
　　Set rng = Intersect(Target, Range("D5:I500"))
　　If rng Is Nothing Then Exit Sub

　　Application.ScreenUpdating = False

　　For Each c In rng.Cells
　　　　v = c.Value
　　　　If IsNumeric(v) And 1 <= v And v <= 31 Then
　　　　　　c.Interior.ColorIndex = xlColorIndexNone
　　　　　　c.Font.ColorIndex = xlColorIndexAutomatic
　　　　　　For Each s In mySh.Range("B3:H7")
　　　　　　　　If s.Value = v Then
　　　　　　　　　　c.Interior.ColorIndex = s.Interior.ColorIndex
　　　　　　　　　　c.Font.ColorIndex = s.Font.ColorIndex
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next s
　　　　End If
　　Next c
　　Application.ScreenUpdating = True
　　Set rng = Nothing
　　Set mySh = Nothing
End Sub

'-------------------------------------------

お礼

お忙しい中にもかかわらず、更なるご丁寧なご回答頂きまして誠にありがとうございました。
100%無事に解決いたしました。私の未熟な説明にも関わらず完璧すぎる回答内容で大変感銘しております。
今回の内容でまさかこれほどモジュールが変更されるとは全く想像もしていませんでした。3～4行コード追加するだけで出来そうにも感じていながら自分で何回試してもうまくいかず、また私自身今回の解決スキームを全然予想理解出来ていなかったことが恥ずかしいですね。
私の課題として今回ご伝授頂きましたモジュール・マクロコードをもう一度振り返り、この全ての理解をきちんとしなければならないと思っております。
今回の改定でかなり複雑高度な内容になっていて自分のレベルでは全て理解するまでもう少々時間がかかりそうですが、何とか頑張って勉強致します。
今般ここまで具体的な内容にてお時間割いていただきご回答頂きましたことにつきましてお礼入力欄だけでは物足りないくらい感謝の気持ちでいっぱいでございます。
ポイント10倍付与したい位の心境ですが、こちらサイトのルール上のこともありますのでお礼入力欄のみにて失礼ながら感謝の姿勢として代えさせて頂きたいと思います。
本当にありがとうございました。

回答No.3

Wendy02

こんにちは。

#1の補足コード
>If Intersect(Target, Range("C4:C500")) Is Nothing Then Exit Sub
>If Target.Count = 1 Then
>If Target.Value <> "" Then Range("J3") = Target.Value

「現行のJ3セルにその入力した英字と同じ値を表示させ次の処理に移行する方法」
補足コードでは、初歩的なことですが、マクロが動かなくなります。

入力値は、数字と限定しています。

> myStr = Range("J3").Value & "セット配色"
J3で、配色セットを取っているわけで、myStrというのは、シート名です。つまり、シート名は、「英字＋セット配色」というものになっていると思うのです。

その点を具体的に、ご説明にならないと、先に進めません。コードは二の次だと思います。

母体になっているのは、以前書いた私のコードのようです。

掲示板で、あまり盛りだくさんに個人的なリクエストを取り入れてコードを作るというのは、本来の掲示板の趣旨に外れていますが、最初からでは、4ヶ月以上も経って、その後も数回見かけてはいましたが、回答はしませんでした。ただ、今も続いていますから、どこかで完成形に近いものは作らなくてはならないと思っています。

おそらく、そのブックの内容は、私たちが読み手側で見るよりも、複雑なもののように思います。

こちらの疑問点をまとめます。（ですます文ではありませんが、ご容赦ください）

'=========================================
・入力値は、数字？それでもって、色を入れる？
・コピー＆ペーストはあるか、ないか？
・セット配色の元のシート名はどのようになっているか？
・J3 には、シート名の一部を入れるようになっているが、それは何か？
・セット配色の切り替えは、どのように、どの時点で行うか？
・なぜ、J3 にシート名の一部と入力値の両方を同時に使わなくてはならないのか？
'=========================================

補足

ご丁寧なご回答誠にありがとうございました。
やはり私の説明がうまく出来ていないようで恐縮でございます。
確かに以前Wendy02様のご指導でこのVBAマクロの大元の基礎構造が出来まして感謝し、この範中のコードの意味も理解できました。その後一部箇所を自身で修正並びに皆様ご協力により現在のマクロに至りましたが、今回の問題で100%完成型になると思っております。

ご指摘頂いております疑問点ですが、

>入力値は、数字？それでもって、色を入れる？

今回のターゲットとなる入力個所は、C4:C500に英字限定で入力します。
またC4:C500個所に色を入れることはないです。

>コピー＆ペーストはあるか、ないか？

C4:C500を入力する際にはコピー＆ペーストは利用しないので使用しないようにしています。

>セット配色の元のシート名はどのようになっているか？

シート名：Aセット配色～Jセット配色の10シート用意しております。

>J3 には、シート名の一部を入れるようになっているが、それは何か？

シート名の一部（A～J）を認識させることによってAセット配色～Jセット配色シートを使い分けるようにしております。現在それをJ3セルに入力された英字値によってコントロールしております。

>セット配色の切り替えは、どのように、どの時点で行うか？

myStr = Range("J3").Value & "セット配色"　時点にて、現在はJ3セル手入力された英字（A～J）を元にセット配色シートの切り替えをしております。

>なぜ、J3 にシート名の一部と入力値の両方を同時に使わなくてはならないのか？

これは、確かにC4:C500範囲内を英字入力する際にそれを認識して処理をした方が良いのじゃないか？J3セルをわざわざ作って表示させる仕様なぞ必要なんかないんじゃないか？と合理性に欠けるとのご指摘意見を受けるかもしれませんが、今回のVBAマクロはせっかくここまでほぼ完成型に近いものが出来ております。
実際の英字入力個所はC4:C500なのですが、現在マクロに組み込まれているJ3セルに入力された英字値によってコントロールする仕様を現状そのまま生かして、C4:C500へエクセル機能の”入力規制リスト”を利用して英字入力限定をし、最後に入力された値を覚えておく（※表示させる）役目のセルをJ3セルにしたいと思っております。
J3セルに現在表示されている英字値がC4:C500内で入力したの最新入力値だなという確認もシート上にて一目でわかるためというのもあります。
今回のご質問の趣旨はこの個所だけに限定をしてご伝授希望を投稿しております。

ちなみに現状ではC4:C500範囲に英字入力をし更にJ3セルにも英字入力をしと手入力が二度手間になっている状況ですのでここを自動化して解決したいと思っております。

>本来の掲示板の趣旨に..．
というご懸念される点も最もと思いますので、

もしお手隙時に気が向いたらで結構でございますので、差し支えなければご回答頂ければ幸いでございます。

回答No.2

nattocurry

> なかなかうまくいきません

これだけでは解りません。
うまくいく、というのは具体的にどういうことなのか。
どうしたときに、どうなって欲しいけど、どうなってしまう、という具体的な事象を教えてください。

> J3セルの更新値（最新の値）はC4：C500範囲内で最後に入力された値になっていればベストと思っております。

C4:C500範囲内で最後に入力された値を覚えておくセルを用意したほうが良いでしょうね。

ところで、前の私の回答はご理解されていますでしょうか？

> 下記のコード、
> If Intersect(Target, Range("C4:C500")) Is Nothing Then Exit Sub
(略)
> を現在のVBAマクロの途中で追加組み込んでみてもなかなかうまくいきませんでして苦悩しております。

というお礼を見て、不安になったのですが。

回答No.1

nattocurry

今は、

Set rng = Intersect(Target, Range("D5:I500"))
If rng Is Nothing Then Exit Sub
D5:I500が変更されたときの処理

という構成になっていますが、それを

Set rng = Intersect(Target, Range("D5:I500"))
If Not rng Is Nothing Then
D5:I500が変更されたときの処理
End If
Set rng = Intersect(Target, Range("C4:C500"))
If Not rng Is Nothing Then
C4:C500が変更されたときの処理
End If

という構成にすればよいと思います。

補足

早速のご回答ありがとうございました。
質問の内容を少々補足いたしますと、
現在はJ3セルに直接入力（myStr = Range("J3").Value & "セット配色"）をしてそれぞれ違うシートを見に行く処理をしておりますが、これをC4：C500範囲内のどこでも入力があった場合にJ3セルに自動表示させたいと思っております。
J3セルの更新値（最新の値）はC4：C500範囲内で最後に入力された値になっていればベストと思っております。

下記のコード、
If Intersect(Target, Range("C4:C500")) Is Nothing Then Exit Sub
If Target.Count = 1 Then
If Target.Value <> "" Then Range("J3") = Target.Value
End If
’C4:C500範囲内にデータ入力があった場合にJ3セルに自動表示する

を現在のVBAマクロの途中で追加組み込んでみてもなかなかうまくいきませんでして苦悩しております。