マクロで色分け

質問

名前の一覧で名前別で1つおきに色分けして見やすくしたいのですが同じ名前が3つの物もあれば2つの物もあるのでどうしたらいいかわかりません。
例えば・・
A1～3にハサミ（この行のセルに色）
A4～5にのり（この行は色なし）
A6～7にえんぴつ（この行のセルに色）
色はすべて同じ色でOKです。
沢山あるので1つ1つの作業はちょっと時間がかかりすぎます。どなたかマクロを教えてください。

回答No.3

うぃず（@Wizard_Zero） · ベストアンサー

#2 Wizard_Zeroです。

すみません。違うコード送信しちゃいました。
こっちが正解です。

Dim I As Long
Dim strBefore As String
Dim blnPaint As Boolean

I = 2

strBefore = Sheet1.Cells(1, 1).Value
blnPaint = True

Do Until Sheet1.Cells(I, 1).Value = ""

'一つ上のセルと内容が異なる場合
If Sheet1.Cells(I, 1).Value <> strBefore Then
'色つけを切り替える
blnPaint = Not blnPaint
strBefore = Sheet1.Cells(I, 1).Value
End If

'blnPaintがTrueのときにセルに色をつけ、Falseのときに色を消す
Sheet1.Cells(I, 1).Interior.ColorIndex = IIf(blnPaint, 6, xlNone)
Sheet1.Cells(I, 1).Interior.Pattern = xlSolid

I = I + 1
Loop

回答No.4

KenKen_SP

回答としては、#1のshkwtaさんの方法が一番よろしいかと。ただ、マクロでということですから、回答させて頂きます。

マクロの方法も#3 Wizard_Zero さんのご回答で、ご希望どおりできます。以下のコードは、Wizard_Zeroさんのパクリm(_ _)m）ですが、ご参考までに。

ユーザーが色分けする範囲、キー列の指定、塗りつぶしの色を指定できるようにして、汎用的に使えるようにしたものです。

【以下コード】

Sub アイテム別で色分け()

　　Dim DataRng As Range, KeysRng As Range, CurrentCell As Range
　　Dim PrevDat As Variant
　　Dim Flag　　As Boolean
　　Dim intColorIndex As Integer

　　'データ範囲の取得------------------------------------------------------
　　On Error Resume Next
　　ActiveCell.Select
　　Set DataRng = Application.InputBox( _
　　Prompt:="色分けする範囲を選択して下さい", Type:=8)
　　If DataRng Is Nothing Then Exit Sub
　　DataRng.Select

　　Set KeysRng = Application.InputBox( _
　　Prompt:="次に、色分けのキーとなる列を選択して下さい", Type:=8)
　　If KeysRng Is Nothing Then
　　　　Exit Sub
　　Else
　　　　If KeysRng.Columns.Count > 1 Then
　　　　　　MsgBox "複数の列は指定できません", vbCritical, "中止"
　　　　　　Exit Sub
　　　　End If
　　　　Set KeysRng = Columns(KeysRng.Column)
　　End If
　　On Error GoTo 0

　　'セルの背景色取得------------------------------------------------------
　　Application.Dialogs(xlDialogPatterns).Show
　　intColorIndex = ActiveCell.Interior.ColorIndex

　　'セルの背景色設定------------------------------------------------------
　　Application.ScreenUpdating = False
　　With Intersect(DataRng, KeysRng)
　　　　.Select
　　　　PrevDat = Cells(.Row, .Column).Value
　　End With

　　Flag = True
　　For Each CurrentCell In Selection
　　　　With CurrentCell
　　　　　　If PrevDat <> .Value Then
　　　　　　　　Flag = Not Flag
　　　　　　　　PrevDat = .Value
　　　　　　End If
　　　　　　With Intersect(Rows(.Row), DataRng).Interior
　　　　　　　　If Flag Then
　　　　　　　　　　.ColorIndex = intColorIndex
　　　　　　　　Else
　　　　　　　　　　.ColorIndex = xlNone
　　　　　　　　End If
　　　　　　End With
　　　　End With
　　Next CurrentCell
　　ActiveCell.Select

End Sub

回答No.2

うぃず（@Wizard_Zero）

Wizard_Zeroと申します。

Dim I As Long

I = 1

Do
Select Case Sheet1.Cells(I, 1).Value
'色をつけたい項目をカンマで区切って並べる
Case "ハサミ", "えんぴつ"
Sheet1.Cells(I, 1).Interior.ColorIndex = 6
Sheet1.Cells(I, 1).Interior.Pattern = xlSolid

'空白のセルがあったらループ終了
Case ""
Exit Do

'それ以外の場合は背景をつけない
Case Else
Sheet1.Cells(I, 1).Interior.ColorIndex = 0

End Select

I = I + 1
Loop

もし、途中に空白行がある場合は、Forループなどに置き換えてください。色は適当です。ColorIndexの値を変えれば変わります。

回答No.1

shkwta

マクロを使わないでできます。
B1に1
B2に =IF(A1=A2,B1,1-B1)
これをB3から下に必要なだけコピー

A1をクリック→書式→条件付き書式→「数式が =B1=1」 と設定→書式の「パターン」で適当な色を設定

A1をコピー
A2から下をドラッグ→形式を選択して貼り付け→書式→ＯＫ