エクセルVBA 同じ品名を色分けする

同じ品名を色分けしたい。セルA1~A100まで品名があり、重複する品名を色分けしたいです。
例　”みかん”をオレンジ　”りんご”を赤　の様に。
よろしくお願いします。

No.4 回答者： Qchan1962 回答日時： 2024/11/22 17:42

定義不足なので、こんな風にやるのはどうですか

多くの品名とセル色のリストを作るのが大変でしょうから・・・
VBAで見える化して

--手作業
作業用シートを作る
元のシート品名の列をコピーして作業用シートA列に貼り付ける

作業用シート表示のまま　下記のVBAを実行
--VBA
Sub SetUpItemsColor()
Dim rng As Range, n As Long
Dim a As Variant, i As Long
Dim R As Integer, G As Integer, B As Integer
Const colm As String = "C"
Set rng = Range("A1:A100")
Columns(colm).Resize(, 2).Clear
With Application
a = .Unique(rng)
For i = 1 To UBound(a)
If .CountIf(rng, a(i, 1)) > 1 Then
R = .RandBetween(0, 255)
G = .RandBetween(0, 255)
B = .RandBetween(0, 255)
With Cells(n + 1, colm)
.Value = a(i, 1)
.Offset(, 1).Interior.Color = RGB(R, G, B)
End With
n = n + 1
End If
Next i
End With
End Sub

C列に重複している品名が出力されます
（重複していない値は出力されない）
D列セルに左対応の暫定色が付きます

--手作業
必要に応じてセルの色を（D列）手動で設定する
例　”みかん”をオレンジ　”りんご”を赤

重複していても色を付けたくない品名があればそのセル（C,D列）を削除上に詰める（または、D列該当セルに色を付けない）

次に
作業用シート表示のまま　下記VBAを実行

--VBA
Sub ColorAllocation()
Dim rng As Range, duplicate_item As Range
Dim c As Range, dupCell As Range

Set rng = Range("A1:A100")
Set duplicate_item = Range("C1", Cells(Rows.Count, "C").End(xlUp))

For Each dupCell In duplicate_item
For Each c In rng
If c.Value = dupCell.Value Then
c.Interior.Color = dupCell.Offset(, 1).Interior.Color
End If
Next c
Next dupCell

End Sub

A列の各セルに設定色が付きます

手動で列をコピーし元のシート列に貼り付ける

この回答へのお礼

簡単そうで、なかなか上手く行きません。
お手数かけました。ありがとうございます。

お礼日時：2024/11/27 04:24

No.3 回答者： ssawatake 回答日時： 2024/11/22 12:03

forループを2重にすれば良いのでは？

for i= 1 to 100

i行目の文字が色付きで無いなら　then
色を決める

　for j= i+1 to 100
　
　　i行目とj行目が同じなら then
　　　i行目とj行目に決めた色を付ける
　　end if
　next j

end i

next i

この回答へのお礼

簡単そうで、なかなか上手く行きません。
お手数かけました。ありがとうございます。

お礼日時：2024/11/27 04:24

No.2 回答者： Qchan1962 回答日時： 2024/11/22 11:17

修正・・・

行操作なのでパラメータは不要でしたね　たぶん
Rows(1).Insert　Rows(1).Delete

No.1 回答者： Qchan1962 回答日時： 2024/11/22 11:03

定義が不足していると思うけれど・・例からすると曖昧ですね

重複している値は最大でいくつ？わかりますよね
もし例の様に指定するなら各アイテムの値とそれに紐づく色をリストなどにする必要がありますね

重複している値同士が単に同じ色で良いなら下記の様なコードで色分けできます
（低い確率ですがランダムで色を指定しているのでバグの可能性があります）
総当たりとフィルタ機能を使う2例（他にも出来そうかな）

Sub Sample()
'シートフィルタ
Dim rng As Range
Dim duplicate_item
Dim i As Integer
Dim R As Integer, G As Integer, B As Integer

Rows(1).Insert shift:=xlShiftDown
Set rng = Range("A1:A101")
rng.Interior.ColorIndex = 0
With Application
duplicate_item = .Unique(rng)
For i = 1 To UBound(duplicate_item)
If .CountIf(rng, duplicate_item(i, 1)) > 1 Then
rng.AutoFilter Field:=1, Criteria1:=duplicate_item(i, 1)
R = .RandBetween(0, 255)
G = .RandBetween(0, 255)
B = .RandBetween(0, 255)
rng.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(R, G, B)
End If
Next
End With
rng.AutoFilter Field:=1, Criteria1:=""
rng.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 0
rng.AutoFilter
Rows(1).Delete shift:=xlShiftDown

End Sub


Sub Sample1()
'条件による総当たり
Dim rng As Range, c As Range
Dim a As Variant, i As Integer
Dim R As Integer, G As Integer, B As Integer
Set rng = Range("A1:A100")
rng.Interior.ColorIndex = 0
With Application
a = .Unique(rng)
For i = 1 To UBound(a)
If .CountIf(rng, a(i, 1)) > 1 Then
R = .RandBetween(0, 255)
G = .RandBetween(0, 255)
B = .RandBetween(0, 255)
For Each c In rng
If c.Value = a(i, 1) Then
c.Interior.Color = RGB(R, G, B)
End If
Next c
End If
Next i
End With
End Sub