人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルマクロ作成依頼です
・シートは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内の一番前から該当があり次第その色が塗られる (りんごは黄)該当無時は何も無。よろしくお願いします

●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:2B A3 RR みかん りんご
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● SALINGER
●100ポイント ベストアンサー

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

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

それで、末尾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/

◎質問者からの返答

SALINGERさんへ

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

●完璧に動作しました。

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


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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ