質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.83%

VBAで色付きセルを条件にメッセージBOXを出したい。

解決済

回答 4

投稿

  • 評価
  • クリップ 0
  • VIEW 1,793

tyano

score 11

前提・実現したいこと

B4~D8にA~Cが入力された表があるとします。
表内の1行に2個以上同じ文字が入力されたら赤いセルになるよう、条件書式を入れています。

表に赤いセルが出現したタイミングで「名前が重複しています」というメッセージBOXを表示させたいです。

イメージ説明

発生している問題・エラーメッセージ

VBA初心者で、添付写真のように見よう見まねで書いてみたのですが、上手くいきません。
ご教授いただければ幸いです。

該当のソースコード

Sub 重複確認()

    If Range("B4:D8").Interior.Color = RGB(255, 0, 0) Then
    AnswerNo = MsgBox("名前が重複しています", vbCritical)

    End If

End Sub

試したこと

ネットで調べてみてもIF文で値をみて条件を出している記事は見るのですが、
色で条件をだしている記事を見かけなくて困っています。

補足情報(FW/ツールのバージョンなど)

ここにより詳細な情報を記載してください。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 4

+2

こんな感じで、
DisplayFormat プロパティ
を使います。

Sub test()
    Dim c As Range

    For Each c In Range("B4:D8")
        If c.DisplayFormat.Interior.Color = vbRed Then
            MsgBox "重複があります。: " & c.Address(False, False)
            Exit Sub
        End If
    Next
End Sub

参考>>
条件付き書式で変更された書式を取得する

追記>>
セルに入力した時にチェックするなら、色がどうのとか関係ないですよね?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngEventArea As Range: Set rngEventArea = Me.Range("B4:D8")

    If Target.CountLarge > 1 Then Exit Sub
    Set Target = Intersect(Target, rngEventArea)
    If Target Is Nothing Then Exit Sub
    Set rngEventArea = Intersect(Target.EntireRow, rngEventArea)

    If WorksheetFunction.CountIf(rngEventArea.Cells, Target.Value) > 1 Then
        MsgBox "既に同じ値を入力済みです。", vbExclamation
        Application.Undo
    End If
End Sub


あぁ、やってみてないけど、同じことがマクロなしでも、入力規則の機能でできるのでは?と思います。
マクロなしで出来るならマクロなしの方が、「元に戻す」がクリアされないので、
そちらの方がより良いかと思います。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/06/02 20:45

    早期にご回答いただき、ありがとうございます!
    DisplayFormat プロパティ!また知らない文が出てきてしまいました 笑
    VBAの道は長く、険しいですね・・・。

    ご提示いただいた文で確かにメッセージBOXを出せました!
    が、セルが赤くなったタイミングではなく、赤い状態でマクロを行った条件ででした。
    難しいです。。。

    キャンセル

  • 2019/06/02 21:26

    負荷が高くなるのでお勧めはしませんが、VBAのコードを書いている上のところにリストが2つあり、WorkSheet , Change を選ぶと、関数が自動で作られます。(Private Sub Worksheet_Change(ByVal Target As Range))

    この中に処理を書けば、マクロ実行時にではなく、ワークシートに変更があったときに実行されます。
    https://www.moug.net/tech/exvba/0050131.html

    キャンセル

  • 2019/06/02 21:44

    調べてみたら、イベントプロシージャ?という名前らしいですね。
    上2つのリストは全然気にもかけていなかったので、勉強になりました!
    お忙しいところご回答いただき、ありがとうございます!

    キャンセル

  • 2019/06/03 10:22

    イベントプロシージャを使いこなせるようになるのが、VBA上級者へのステップですね。

    キャンセル

checkベストアンサー

+1

既に、回答がついていて、重複する部分もありますが、

表に赤いセルが出現したタイミングで「名前が重複しています」というメッセージBOXを表示させたいです。

「表に赤いセルが出現したタイミング」となると、Worksheet_Change を使うことになりますね。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Intersect(Target, Range("B4:D8"))
    If rng Is Nothing Then Exit Sub

    Dim c As Range
    For Each c In rng.Cells
        If c.DisplayFormat.Interior.Color = vbRed Then
            MsgBox "名前が重複しています", vbCritical
            Exit For
        End If
    Next
End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/06/02 20:38

    早期にご回答いただき、ありがとうございます!
    試してみたのですが、緑の▶ボタン(ユーザーフォームの実行?)を押しても名前が無く、
    マクロを実行することが出来ませんでした・・・。

    キャンセル

  • 2019/06/02 21:40

    ユーザーフォームの実行は不要なんですね!
    そのままシートのマクロに記入したらいけました!
    お忙しいところありがとうございます!

    キャンセル

0

色で判定しなくても、条件付き書式の条件(色を付けている条件)で判定するで良いのではないでしょうか?

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/06/02 16:54

    確かに、色がつけばそれはそれでわかるのですが、勉強の一環として、
    色でメッセージBOXを出せるのか気になっております。

    キャンセル

  • 2019/06/02 17:02

    なるほど、そういうことですね。

    色でメッセージ自体は、記載のコードで判断できています。
    メッセージがでないのは、Range("B4:D8")の部分が原因で、Range("B4:D8")だとその部分全て(15セル)が赤じゃないとif条件がTrueになりません。

    画像の状態だと、Range("B4:C4")にするとメッセージが出ると思います。

    キャンセル

  • 2019/06/02 20:40

    早期にご回答いただき、ありがとうございます!
    なるほど!だからメッセージが出なかったんですね!
    その中のどれかが、となるとこのIF文では難しいですね・・・。

    キャンセル

  • 2019/06/03 10:26

    セル範囲を絞ったとしても、Interior.Color では条件付き書式で変化した色は取得できません。
    DisplayFormat.Interior.Color でないと。
    すでに回答に出てますが、念のために。

    キャンセル

0

事前に条件書式を入れなくても確認できる方法です。
試してみてください

Sub JufukuKakunin()
    Dim i As Long, j As Long
    For i = 4 To 8
        For j = 2 To 4
            If Application.WorksheetFunction.CountIf(Range(Cells(i, 2), Cells(i, 4)), Cells(i, j)) > 1 Then
                Cells(i, j).Select
                Cells(i, j).Interior.ColorIndex = 3
                MsgBox "重複があります。"
                Exit Sub
            Else
                Cells(i, j).Interior.ColorIndex = 0
            End If
        Next j
    Next i
End Sub

<別解を追記>
行単位の重複を調査したい範囲で一度に確認する場合の記載は以下となります。

Sub JufukuKakunin2()
    Dim i As Long, j As Long
    Dim bF As Boolean
    For i = 4 To 8
        For j = 2 To 4
            If Application.WorksheetFunction.CountIf(Range(Cells(i, 2), Cells(i, 4)), Cells(i, j)) > 1 Then
                Cells(i, j).Interior.ColorIndex = 3
                bF = True
            Else
                Cells(i, j).Interior.ColorIndex = 0
            End If
        Next j
    Next i
    If bF Then
        MsgBox "名前が重複している箇所を赤字にしました。"
    End If
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/06/02 20:49

    早期にご回答いただき、ありがとうございます!
    条件書式をVBAで行うことも出来るなんで凄すぎます!

    確かに最初の表の状態であれば赤くなりましたが、複数の行で文字が被っている場合は
    最初の行のみが赤くなり、2行目以降は白色セルのままになってしまいました。。。

    キャンセル

  • 2019/06/02 20:54

    このマクロは、上から1行ずつ左列から右列に確認していき、最初に文字の重複が見つかったセルを赤くして終了するようにしています。
    いろんなやり方がありますので、目的に合うよう修正してみてください。

    キャンセル

  • 2019/06/02 21:17

    別解を追記しましたので、試してみてください。
    条件書式を用いることが必須でなければ、この方法がシンプルに実現できると思います。

    キャンセル

  • 2019/06/02 21:42

    別解の追記もありがとうございます!
    条件書式、入力規制、VBAと色々な方法があることがわかりました!
    まだまだVBAは全然わかりませんが、慣れるように勉強します。
    ありがとうございました!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.83%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る