[[20200820184557]]　『重複に色づけについて』（fuku）　ページの最後に飛ぶ

『重複に色づけについて』（fuku）

ご指導よろしくお願いします。

重複カ所を確認するため
以下（WEB上で探し）シートに合うよう若干修正してtestしてみたのですが
★部分エラー"インデックスが有効範囲にありません"が出てしまいます。
データはA～L列にあります（ところどころ空白セルも存在）
1～700から800行あります。
重複確認対象はF列（文字列）です。

教えていただきたいのは対象となる行（A～Lまで）色づけしたい。
エラーを回避方法をご教授お願いします。
Sub test()

    Dim DIC As Object
    Dim cw As String
    Dim i As Long
    Dim iCol As Long

    iCol = 3

    Columns("F:F").Interior.ColorIndex = xlNone

    Set DIC = CreateObject("Scripting.Dictionary")
    For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
        cw = Cells(i, "F").Value
        If DIC.exists(cw) = False Then
            DIC.Add cw, "F" & i
        Else
            DIC(cw) = DIC(cw) & ",F" & i
        End If
    Next i

    For i = 0 To DIC.Count - 1
        cw = DIC.items()(i)
        If 0 < InStr(cw, ",") Then
            iCol = iCol + 1
            Range(cw).Interior.ColorIndex = iCol　’★
        End If
    Next i
 End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 重複カ所に色付けでいいんですよね？
    Sub test()
        Dim DIC As Object
        Dim i As Long
        Dim r As Range
        Dim rng As Range
        Dim clRng As Range
        Set clRng = Columns("A:L")
        Set DIC = CreateObject("Scripting.Dictionary")
        For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
            With Cells(i, "F")
                If DIC.exists(.Value) Then
                    If rng Is Nothing Then
                        Set rng = clRng.Rows(i)
                    Else
                        Set rng = Union(rng, clRng.Rows(i))
                    End If
                End If
                DIC(.Value) = ""
            End With
        Next i
        Set DIC = Nothing
        clRng.Interior.Color = xlNone
        If Not rng Is Nothing Then rng.Interior.ColorIndex = 3         '★
     End Sub

（稲葉） 2020/08/20(木) 19:20

（稲葉）さん
ありがとうございます。
ボタンに登録し無事出来ました。が
ひとつボタンを2度クリックしたとき　xlNone　色消しを
追加出来ませんか
一度に質問せずに
申し訳ないですがよろしくお願いします。
（fuku） 2020/08/20(木) 19:48

 >ひとつボタンを2度クリックしたとき
 意味がわからないのですが。
 今回のマクロを登録したボタンを、再度クリックした場合ってことですか？
 できますけど、分けたほうがいいです。

 その場合自分でできますよね？
（稲葉） 2020/08/20(木) 21:30

こんな感じの条件付き書式ではだめですか
=AND(COUNTIF($F$1:$F1,$F1)>1,$M$1=1)

で、マクロで、M1の値を切り替える

（マナ） 2020/08/20(木) 22:09

オプションボタンとかトグルボタンを使えばマクロも不要ですね

（マナ） 2020/08/20(木) 22:13

（稲葉）さん
ありがとうございます。以下了解しました。

今回のマクロを登録したボタンを、再度クリックした場合ってことですか？できますけど、分けたほうがいいです。

ただ、いろいろtestしてみたのですが＜重複＞の着色は複数存在する重複の内
１つの重複は、着色されないようになっているようなのですが　２つの場合は
対象１行　３つある場合は対象２行　４つある場合対象３行が着色になるのですが
対象の重複全て色づけが可能でしょうか？

よろしくお願いします。
（マナ）さん
ありがとうございます。
ちょっとと理解できませんでしたすみません。
（fuku） 2020/08/21(金) 04:09

（稲葉）さん
更に、何度かtestいたしましたが
色数が１つだと、かなり対象を選別するのが(行数が多くデータも飛び飛びなので)煩雑になります。
できれば、最初に当方で書き込んだマクロ(こちらは対象グループごとに色違いで着色)
されるので判別がわかりやすいです。
出来ることであれば着色方法を検討いただけないでしょうか？
ご無理を申し上げ誠に心苦しいのですがよろしくお願いします。

★部分エラー"インデックスが有効範囲にありません"は、色数が足りなくて
エラーとなるのでしょうか？エラーは出ますが途中の行までは着色(F列のみですが)しています。

（fuku） 2020/08/21(金) 04:36

 >★部分エラー"インデックスが有効範囲にありません"は、色数が足りなくて
 データみてないのでわかりません。
 パソコンつけたら書き直します
（稲葉） 2020/08/21(金) 05:33

（稲葉）さん
返事ありがとうございます。
試しに、行数(データ)を減らしtest実行しました結果
たぶん、色数減になりエラー出ませんでした。
今回のデータは、約500行で重複の数は約ですが70通り前後あります。
カラーコードは56色？当たりでしょうか　あまり濃い色ではデータが
見にくくなりますよね・・・

 ＞データみてないのでわかりません。
 ＞パソコンつけたら書き直します
何卒、よろしくお願いします。
（fuku） 2020/08/21(金) 05:51

70通りもパターンがあるなら、ColorIndex は足りませんね。上限を超えた分は着色しないとか、1に戻すとか？（そもそも、そんなに多色にしても、判りにくいだけでしょうに…。上位10件だけにしては？）

または、ColorIndexを止めて、ColorプロパティにRGB指定にすれば、256*256*256通りに塗れますよ。その微妙な色の差を、人間の目で見て認識できるとは思えませんが、100通りくらいに絞るとか。
（???） 2020/08/21(金) 11:19

 70!?
 ううううん
 91通りまでひとまず分けられたけど、男の私には判断できません・・・
 重複チェックより、色を作るのに時間かかった・・・
 あとマクロ実行後に、処理を選ぶもの入れました。簡易機能ですが。
    Option Explicit
    Sub test()
        Dim dic As Object
        Dim i As Long
        Dim clRng As Range
        Dim itm As Variant
        Dim c As Variant
        Dim cnt As Long
        Set clRng = Columns("A:L")
        Select Case MsgBox("色の削除 = はい" & vbCrLf & "重複チェック = いいえ" & vbCrLf & "処理の中断 = Cancel", vbYesNoCancel)
            Case vbCancel: MsgBox "処理を中断します"
            Case vbYes: clRng.Interior.Color = xlNone
            Case vbNo
                Set dic = CreateObject("Scripting.Dictionary")
                For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
                    With Cells(i, "F")
                        If Not dic.exists(.Value) Then
                            Set dic(.Value) = clRng.Rows(i)
                        Else
                            Set dic(.Value) = Union(dic(.Value), clRng.Rows(i))
                        End If
                    End With
                Next i
                clRng.Interior.Color = xlNone
                c = mk_color
                cnt = 0
                For Each itm In dic.items
                    If itm.Count > 1 Then
                        itm.Interior.Color = c(cnt)
                        cnt = cnt + 1
                        If UBound(c) < cnt Then
                            MsgBox "配色上限を超えました。処理を中断します"
                            Exit Sub
                        End If
                    End If
                Next itm
                Set dic = Nothing
                MsgBox "色分けが完了しました:" & cnt - 1 & "色"
        End Select
     End Sub

    Function mk_color() As Variant
        Dim c As Long
        Dim cnt As Long
        Dim v As Variant
        cnt = 0
        ReDim v(1000)
        For c = 50 To 230 Step 15
            v(cnt + 0) = RGB(255, 0, c)
            v(cnt + 1) = RGB(0, 255, c)
            v(cnt + 2) = RGB(c, 0, 255)
            v(cnt + 3) = RGB(255, c, 0)
            v(cnt + 4) = RGB(c, 255, 0)
            v(cnt + 5) = RGB(0, c, 255)
            v(cnt + 6) = RGB(c, c, c)
            cnt = cnt + 7
        Next c
        ReDim Preserve v(cnt)
        mk_color = v
    End Function
（稲葉） 2020/08/21(金) 11:28

おーすごいですね　ご無理申し上げました申し訳ありません感謝です
ありがとうございます。

見事に色分けできています。80色とでました。
91通りまでとありましたので、ギリギリですね
もっと多い場合は、このマクロでも無理ということですかね

最後に、対象行全部着色(単色)　2020/08/20(木) 19:20test　するには
データ多過ぎ91色でもエラー時利用したいと思うので、どのようにすれば
いいですか？何度もすみません。
よろしくお願いします。

（fuku） 2020/08/21(金) 13:10

 >For c = 50 To 230 Step 15
 この部分調整すれば、増やせます
 step 15を、step 5にすれば、270色です
 見分けがつかないのに、色分けする必要を感じないので、全部同じ色か、???さんの言う通り、top10だけにすればいいと思いますけどね

 それよりも、隣のセルに重複であるしるしつけたほうがいいと思いますけどねぇ
 そうすれば、数式ですみますし。
（稲葉） 2020/08/21(金) 14:29

（稲葉）さん
ありがとうございます。
えっー数式でもできますか？
＞それよりも、隣のセルに重複であるしるしつけたほうがいいと思いますけどねぇ
＞そうすれば、数式ですみますし。
（fuku） 2020/08/21(金) 15:08

 G1=if(countif(f:f,f1)>1,"重複")
 これでいいんじゃないですか？
（稲葉） 2020/08/21(金) 15:28

（稲葉）さん
昨日から長々ありがとうございました。
希望通りのデータが作成できました。
また、よろしくお願いします。
（fuku） 2020/08/21(金) 17:11

コメント返信：

[ 一覧(最新更新順) ]

[[20200820184557]] 『重複に色づけについて』（fuku） ページの最後に飛ぶ

[[20200820184557]]　『重複に色づけについて』（fuku）　ページの最後に飛ぶ