エクセルマクロ作成依頼です

・シートは2つ(★と■)
・★はA列に1セル30文字程度が並ぶ(無制限)各セル末尾の全角4文字分(8B)(少ない時有)に指定の文字を含む。
・■には1行目のA~Z迄に色が塗ってあり、2行~50行間(空白セル有)迄に先の8B内に使われる文字が並ぶ。A2~Z50までで種類は別々。小大文字の区別はします(2B以内)
例★シート
 A
1りんごs1rr2
2みかんLre3
3メロンA13

■シート
  A B C ~Z
1 赤 黄 緑
2 L  13 rr
3   s1  5

マクロ実行で★A列セルが、それぞれ■の列の色に染まる。
★A3に末尾8B内に13があり、■B列に13があるので★A3はB列の黄に。みかんは赤。
検索は8B内の一番前から該当があり次第その色が塗られる (りんごは黄)該当無時は何も無。よろしくお願いします

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2009/05/15 11:38:24
  • 終了:2009/05/15 17:46:14

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/05/15 15:54:17

ポイント100pt

とりあえず作成してみました。

ただ、問題点としてセル末尾の指定の文字は長さが不定なので、それ以外との区別がつかないということです。

それで、末尾4文字(半角を0.5文字)の中にA2~A50の文字が含まれているかどうかで判断しています。


コード中の★や■を実際のシート名に変更して実行してみてください。

Sub Macro()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Integer
    Dim str1 As String
    Dim str2 As String
    Dim res As Integer
    
    '実際のシート名に変更してください
    Set ws1 = Worksheets("★")
    Set ws2 = Worksheets("■")
    
    lastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        '後から8バイトの取得
        str1 = ws1.Cells(i, 1).Value
        If LenB(StrConv(Right(str1, 5), vbFromUnicode)) <= 8 Then
            If LenB(StrConv(Right(str1, 6), vbFromUnicode)) <= 8 Then
                If LenB(StrConv(Right(str1, 7), vbFromUnicode)) <= 8 Then
                    If LenB(StrConv(Right(str1, 8), vbFromUnicode)) <= 8 Then
                        str2 = Right(str1, 8)
                    Else
                        str2 = Right(str1, 7)
                    End If
                Else
                    str2 = Right(str1, 6)
                End If
            Else
                str2 = Right(str1, 5)
            End If
        Else
            str2 = Right(str1, 4)
        End If
        
        For j = 1 To Len(str2)
            res = GetColor(Mid(str2, j, 1))
            If res <> -1 Then
                Exit For
            End If
            If j <> Len(str2) Then
                res = GetColor(Mid(str2, j, 2))
                If res <> -1 Then
                    Exit For
                End If
            End If
        Next
        
        If res = -1 Then
            ws1.Cells(i, 1).Interior.ColorIndex = -4142
        Else
            ws1.Cells(i, 1).Interior.ColorIndex = res
        End If
    Next
End Sub

Function GetColor(str As String) As Integer
    Dim r
    With Worksheets("■")
        Set r = .Range("A2:Z50").Find(what:=str, LookAt:=xlWhole, MatchCase:=True, MatchByte:=True)
        If Not r Is Nothing Then
            GetColor = .Cells(1, r.Column).Interior.ColorIndex
        Else
            GetColor = -1
        End If
    End With
End Function

意図した動作ではない場合や、質問がある場合はコメント欄で対応します。

http://q.hatena.ne.jp/

id:naranara19

SALINGERさんへ

本当にいつもありがとうございます。

●完璧に動作しました。

文字数制限から、依頼なのに、ぶっきらぼうな依頼文で大変失礼いたしました。


SALINGERさんの早くて正確な技術に感服いたします。

また、優しさをいつも感じます。

本当にありがとうございました。

2009/05/15 17:45:31

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

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

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

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

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