同じ値を探し出して、行を並び替え、色をつけるVBAマクロをお願いいたします。



顧客リストがあります。

A列には商品名
F列にお客様名が並んでいます。


A,F
1りんご,高橋一
2みかん,斉藤二
3オレンジ,高橋一
4すいか,田中三
5桃,高橋一
6レモン,鈴木四
7苺,斉藤二


ここでマクロをかけると↓

1りんご,高橋一
2オレンジ,高橋一
3桃,高橋一
4みかん,斉藤二
5苺,斉藤二
6すいか,田中三
7レモン,鈴木四

と列ごと並び替えられるようにしてほしいのです。
同じ名前を比べて同じ名前の一番上の行のすぐ下に並んでいくイメージです。
(同性同名はこの際無視します)

そして、同じ名前が発生したときには、今回の例では
A1~F3まで黄色、A4~F4まではオレンジなどと自動的にセルに色を塗るようにして下さい。(途中のB,C,Dも色塗り)

色の順番は上から、
黄色⇒橙⇒黄緑⇒水色⇒濃青⇒薄灰⇒濃灰⇒濃緑⇒黒
でお願いします。コード内でRGB値を調節できるようにしておいて下さい。

それ以降は適当にRGB値をランダムに調整してくださると助かります。

よろしくお願いいたします。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2010/07/24 12:22:42
  • 終了:2010/07/25 00:46:31

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692010/07/24 16:19:34

ポイント100pt

修正しました。

それと、背景が白に塗りつぶす場合も除外もついでに除外しておきました。


Sub Macro()
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim k As Long
    Dim h As Variant
    Dim l As Integer
    Dim f As Boolean
    Dim c As Integer
    
    '色の指定
    h = Array(6, 45, 35, 20, 5, 15, 16, 10, 1)
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        k = i
        For j = i + 1 To lastRow
            If Cells(i, "F").Value = Cells(j, "F").Value Then
                If j <> i + 1 Then
                    Rows(j).Cut
                    Rows(i + 1).Insert Shift:=xlDown
                End If
                i = i + 1
            End If
        Next j
        If k < i Then
            l = l + 1
            If l <= UBound(h) + 1 Then
                Range("A" & k & ":F" & i).Interior.ColorIndex = h(l - 1)
            Else
                Do
                    f = False
                    c = c + 1
                    If c = 2 Then
                        f = True
                    Else
                        For j = 0 To UBound(h)
                            If h(j) = c Then
                                f = True
                                Exit For
                            End If
                        Next
                    End If
                Loop While f
                Range("A" & k & ":F" & i).Interior.ColorIndex = c
            End If
        End If
    Next i
End Sub
id:naranara19

ありがとうございました!きちんと動きました。いつもありがとうございます。優しいSALINGERさんにいつも救われております。本当に感謝しております。

2010/07/25 00:45:10

その他の回答(3件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692010/07/24 14:01:27

ポイント70pt

色はインデックスカラーにしていて、コード中の色の指定のところで

最初の色だけを指定しています。

インデックスカラーはこちらとかで番号を確認できます。

http://homepage3.nifty.com/boole/reference.htm


最初の9色の後は使っていないインデックスカラーを使います。

56色以上は無いのでエラーとなります。

RGBで更に細かく色を指定したい場合は、コードを修正しますが、

その場合10色目以降をどのように決定するかが曖昧です。


Sub Macro()
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim k As Long
    Dim h As Variant
    Dim l As Integer
    Dim f As Boolean
    Dim c As Integer
    
    '色の指定
    h = Array(6, 45, 35, 20, 5, 15, 16, 10, 1)
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        k = i
        For j = i + 1 To lastRow
            If Cells(i, "F").Value = Cells(j, "F").Value Then
                If j <> i + 1 Then
                    Rows(j).Cut
                    Rows(i + 1).Insert Shift:=xlDown
                End If
                i = i + 1
            End If
        Next j
        l = l + 1
        If l <= UBound(h) + 1 Then
            Range("A" & k & ":F" & i).Interior.ColorIndex = h(l - 1)
        Else
            Do
                f = False
                c = c + 1
                For j = 0 To UBound(h)
                    If h(j) = c Then
                        f = True
                        Exit For
                    End If
                Next
            Loop While f
            Range("A" & k & ":F" & i).Interior.ColorIndex = c
        End If
    Next i
End Sub
id:naranara19

いつもありがとうございます!

早速やってみたのですが、お二人とも、同じ人以外のときも色が塗られてしまいまして。

同じ名前が2人以上のときのみ、色を塗っていただきたいのです。それ以外は塗らなくて結構です。ちょっと質問の仕方がまずかったかと思います。

恐れ入りますがよろしくお願いいたします。

2010/07/24 15:36:52
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912010/07/24 14:32:31

ポイント70pt

一応仕様通りに作成してみました。

同じ色を繰り返し使用する場合は、ColorLoopMode を True にして見てください。

Option Explicit

'// 色の使用方法
Const ColorLoopMode = False
' True  ・・・・ 定義された色を繰り返し使用
' False ・・・・ 定義された色が終わったら、ランダムな色を使用

Sub naranaraPaint()
    '// 色の定義:定義されている分だけ使用
    Dim cArray As Variant
    cArray = Array(RGB(255, 255, 0), RGB(255, 192, 0), RGB(146, 208, 80), RGB(0, 176, 240), RGB(0, 0, 255), _
                    RGB(216, 216, 216), RGB(128, 128, 128), RGB(0, 176, 80), RGB(0, 0, 0))

    '// データの並べ替え
    Columns("A:F").Sort Key1:=Range("F1"), order1:=xlAscending, Header:=xlGuess, Orientation:=xlTopToBottom

    
    
    '// セルの着色
    Dim r As Integer
    r = 1
   
    Dim ci As Long
    ci = 0
    
    Dim cl As Long
    cl = cArray(ci)
    Do While Cells(r, "F") <> ""
        Range(Cells(r, "A"), Cells(r, "F")).Interior.Color = cl
        If Cells(r, "F").Value <> Cells(r + 1, "F").Value Then ci = ci + 1
        If ColorLoopMode = True And ci > UBound(cArray) Then ci = 0
        
        If ci <= UBound(cArray) Then
            cl = cArray(ci)
        Else
            cl = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
        End If
        r = r + 1
    Loop
End Sub
id:naranara19

お久しぶりです。画像の連結の際にはうまく回答できず、すみませんでした。


早速やってみたのですが、お二人とも、同じ人以外のときも色が塗られてしまいまして。

同じ名前が2人以上のときのみ、色を塗っていただきたいのです。それ以外は塗らなくて結構です。ちょっと質問の仕方がまずかったかと思います。

恐れ入りますがよろしくお願いいたします。

2010/07/24 15:37:41
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692010/07/24 16:19:34ここでベストアンサー

ポイント100pt

修正しました。

それと、背景が白に塗りつぶす場合も除外もついでに除外しておきました。


Sub Macro()
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim k As Long
    Dim h As Variant
    Dim l As Integer
    Dim f As Boolean
    Dim c As Integer
    
    '色の指定
    h = Array(6, 45, 35, 20, 5, 15, 16, 10, 1)
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        k = i
        For j = i + 1 To lastRow
            If Cells(i, "F").Value = Cells(j, "F").Value Then
                If j <> i + 1 Then
                    Rows(j).Cut
                    Rows(i + 1).Insert Shift:=xlDown
                End If
                i = i + 1
            End If
        Next j
        If k < i Then
            l = l + 1
            If l <= UBound(h) + 1 Then
                Range("A" & k & ":F" & i).Interior.ColorIndex = h(l - 1)
            Else
                Do
                    f = False
                    c = c + 1
                    If c = 2 Then
                        f = True
                    Else
                        For j = 0 To UBound(h)
                            If h(j) = c Then
                                f = True
                                Exit For
                            End If
                        Next
                    End If
                Loop While f
                Range("A" & k & ":F" & i).Interior.ColorIndex = c
            End If
        End If
    Next i
End Sub
id:naranara19

ありがとうございました!きちんと動きました。いつもありがとうございます。優しいSALINGERさんにいつも救われております。本当に感謝しております。

2010/07/25 00:45:10
id:iimmrr No.4

iimmrr回答回数3ベストアンサー獲得回数02010/07/24 23:56:07

ポイント20pt

大変僭越ながら、コメントさせて頂きます。

人名でソートなど、マクロを使わなくても、エクセルのソート機能を使い、一瞬でできると思います。

どのバージョンのエクセルか分かりませんが[データ]→[オートフィルタ]で、矢印ができますので、

その矢印を押して、データのソートはできますし、できなくても「A→Z」等のアイコンがあるので、

データがすべてはいっている範囲(データの左上から右下)を選択して、さっきの「a→Z」というボタンを押し、

メニューに沿って処理すれば、並び替えは簡単にできます。

詳細な使い方は、申し訳ありませんが、ググって下さい。

ググれば、理解するのに1時間もかかりません。

ググれなくてもモガイダンスにしたがって操作すればいいです。

それぐらい簡単な処理は、自分でやってから、お話した方がいいと思うのです。

さらに言うなら、2行以上名前がかぶっているというのも、すぐにエクセル関数で、出せると思います。

そこまでやって、色を塗りたいのですが、やってください、と言うと、とても効率がいいと思います。

できることをやってからの方が質問しても、いい結果が返ってくると思います。

そうしていただけば、回答する人もしやすいかと思います。

そんなことよりも、私は黙々とソース書いている人を見て、「あーなんて、この人たちはすばらしいのだろう。こういう人が世の中にたくさんいるから、世の中が動いているでしょうね。」と一種の感動を覚えました。

id:naranara19

もちろん、データの並び替え等くらいは私でもできます。ただ、毎日同じ処理をするのですから、そのの1分1秒を節約したいのです。そして、今回ご回答いただける方々はいつもご協力してくださっている方々でして。こちらとしてもご回答いただいているお二人を大変信用しております。アドバイスは嬉しいのですが、マクロ部分は割りきってお願いしているのです。大変良いできばかりですし、非常に助かっております。また、無料ではなくきちんとわずかですがお礼を渡せるのが「はてな」のいいところだと思っています。ご指摘いただける部分はわかるのですが、そのご回答はヤフーの知恵袋やOKWAVEがより向いていると思います。

2010/07/25 00:44:13

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません