| |
▼やま さん：
おはようございます。
>やっとここまで出来ました
>これに範囲D4からデータのあるD列最終行と
>色設定を教えて下さい。よろしくお願いします。
>色は １位に・・・赤
> ２位に・・・緑
> ３位に・・・青
> ４位に・・・ピンク
> ５位に・・・オレンジ です
以前作成したFindメソッドのサブルーチンが目に付いたので
これを使いました。
標準モジュールに
'============================================================
Sub 番号順()
Dim i As Long
Dim j As Long
Dim ans As Variant
Dim rng As Range
Dim samecnt As Long
Dim clarray As Variant
j = 1
clarray = Array(3, 10, 5, 7, 46)
With Range("d4", Cells(Rows.Count, "d").End(xlUp))
For i = 1 To 5
j = j + samecnt
ans = Application.Large(.Cells, j)
If IsError(ans) Then Exit For
samecnt = Application.CountIf(.Cells, ans)
Set rng = get_findcell(ans, .Cells)
Do Until rng Is Nothing
rng.Interior.ColorIndex = clarray(i - 1)
Set rng = get_findcell()
Loop
Next
End With
End Sub
'============================================================
Function get_findcell(Optional ByVal f_v As Variant = "", _
Optional ByVal rng As Range = Nothing, _
Optional ByVal alookin As XlFindLookIn = -4163, _
Optional ByVal alookat As XlLookAt = 1, _
Optional ByVal aso As XlSearchOrder = 1, _
Optional ByVal asd As XlSearchDirection = 1, _
Optional ByVal mc As Boolean = False, _
Optional ByVal mb As Boolean = True) As Range
'指定された値でセル範囲を検索し､該当するセルを取得する
'input : f_v 検索する値
' rng 検索する範囲
' alookin 検索対象 xlvalues,xlformulas,xlcomments
' alookat: :検索方法 1-完全一致 2-部分一致
' aso : 検索順序 1 行 2 列
' asd : 検索方向 1 Xlnext 2 XlPrevious
' mc : 大文字・小文字の区別 False しない True する
' mb : 半角と全角を区別 True する False しない
'output:get_findcell 見つかったセル(見つからなかったときはNothingが返る)
Static 検索範囲 As Range
Static 最初に見つかったセル As Range
Static 直前に見つかったセル As Range
Static 検索方向 As XlSearchDirection
If Not rng Is Nothing Then
Set 検索範囲 = rng
End If
If f_v <> "" Then
Set get_findcell = 検索範囲.Find(f_v, 検索範囲.Cells(検索範囲.Rows.Count, 検索範囲.Columns.Count), _
alookin, alookat, aso, asd, mc, mb)
If Not get_findcell Is Nothing Then
Set 最初に見つかったセル = get_findcell
Set 直前に見つかったセル = get_findcell
検索方向 = asd
End If
Else
If 検索方向 = xlNext Then
Set get_findcell = 検索範囲.FindNext(直前に見つかったセル)
Else
Set get_findcell = 検索範囲.FindPrevious(直前に見つかったセル)
End If
If get_findcell.Address = 最初に見つかったセル.Address Then
Set get_findcell = Nothing
Else
Set 直前に見つかったセル = get_findcell
End If
End If
End Function
同じ数字があっても取り合えず、
1番大きい数字のあるセルは、全部 赤に塗りつぶす
2番目に大きい数字のあるセルは、全部 緑に塗りつぶす
・
・
という処理にしました。
意味合いが違うなら、プロシジャー番号順を変更してください。
|
|
ichinose
- 07/5/31(木) 7:51 -
