[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『背景色のある行番号を取得するユーザー定義関数』（TK）
件名のプログラムを作成しましたが、もう少し軽くする方法があれば教えていただきたいです。
参照した範囲で色のついているセルの行番号を対象セルに出力する。データはカンマで区切っていますがなんでもいいです。
Function FuncColor(arg As Range)
Dim found As Boolean, cell As Range, ans As Variant
found = False
For Each cell In arg
If cell.Interior.Color <> "16777215" Then
ans = ans & "," & cell.Row
End If
If found = False Then
If cell.Interior.Color <> "16777215" Then
ans = cell.Row
found = True
End If
End If
Next cell
FuncColor = ans
Application.Volatile
End Function
＜ 使用 Excel：Microsoft365、使用 OS：unknown ＞
以下のようにも書けます。
Function FuncColor2(arg As Range) As String
Dim cell As Range, ans As String
Application.Volatile
For Each cell In arg
If cell.Interior.Color <> vbWhite Then
ans = ans & "," & cell.Row
End If
Next cell
FuncColor2 = Mid(ans, 2)
End Function
【備考】
1. "白"と"塗りつぶし色なし"は区別しません。
もし（白を含めた)"塗りつぶし"ありを区別するには、
cell.Interior.ColorIndex <> xlColorIndexNone とします。
2. 対象範囲の塗りつぶし色を変えただけでは、再計算されないことに注意が必要です。
3. 条件付き書式による色は対象外であることにも注意が必要です。（対象とする方法はあります）
手動で赤の塗りつぶし色としており、その後、条件付き書式の結果、白になった場合、
見かけは白ですが、塗りつぶし色ありと判定されます。
（xyz） 2023/10/31(火) 06:01:41
Rem [clsRect]クラスモジュール ******************************************************************************************
Option Explicit
Public Left As Long
Public Top As Long
Public Right As Long
Public Bottom As Long
Public Property Get ToAddress(Optional ByVal RefStyle As XlReferenceStyle = xlA1) As String
Rem デバッグ用プロパティ(要らん)
Dim a As String
a = "R" & Top & "C" & Left & ":R" & Bottom & "C" & Right
If RefStyle <> xlA1 Then
ToAddress = Application.ConvertFormula(a, xlR1C1)
Else
ToAddress = Application.ConvertFormula(a, xlR1C1, xlA1, xlRelative)
End If
End Property
Rem 標準モジュール *****************************************************************************************************
Option Explicit
Private Function CreateInteriorColorList(Optional ChkArea As Range) As Object
If ChkArea Is Nothing Then
If ActiveSheet Is Nothing Then Exit Function
Set ChkArea = ActiveWindow.RangeSelection
End If
Dim Dic As Object
Dim iArea As Range, a As Range, c As Range
Set Dic = CreateObject("Scripting.Dictionary")
If IsNull(ChkArea.Interior.ColorIndex) Then
Dim uRect As Range, UnUsedR As Range, UnUsedB As Range, UnUsedBR As Range, LastCell As Range
With ChkArea.Worksheet
Set uRect = .Range("A1", .UsedRange)
Set LastCell = .Cells(uRect.Rows.Count, uRect.Columns.Count)
If LastCell.Column < .Columns.Count Then
Set UnUsedR = .Range(.Cells(1, LastCell.Column + 1), .Cells(LastCell.Row, .Columns.Count))
If LastCell.Row < .Rows.Count Then Set UnUsedBR = .Range(LastCell.Offset(1, 1), .Cells(.Rows.Count, Columns.Count))
End If
If LastCell.Row < .Rows.Count Then Set UnUsedB = .Range(.Cells(LastCell.Row + 1, 1), .Cells(.Rows.Count, LastCell.Column))
End With
For Each iArea In ChkArea.Areas
If IsNull(iArea.Interior.ColorIndex) Then
Set a = Intersect(iArea, uRect)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
If a.Rows.Count > a.Columns.Count Then
CreateInteriorColorList_ChkColumns Dic, a
Else
CreateInteriorColorList_ChkRows Dic, a
End If
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedR)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
For Each c In a.Rows
CreateInteriorColorList_DicAdd Dic, c
Next
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedB)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
For Each c In a.Columns
CreateInteriorColorList_DicAdd Dic, c
Next
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedBR)
If Not a Is Nothing Then
CreateInteriorColorList_DicAdd Dic, a
End If
Else
CreateInteriorColorList_DicAdd Dic, iArea
End If
Next
Else
CreateInteriorColorList_DicAdd Dic, ChkArea
End If
Set CreateInteriorColorList = Dic
End Function
Private Sub CreateInteriorColorList_ChkRows(d As Object, a As Range)
Dim r As Range
For Each r In a.Rows
If IsNull(r.Interior.ColorIndex) Then
Call CreateInteriorColorList_ChkColumns(d, r)
Else
CreateInteriorColorList_DicAdd d, r
End If
Next
End Sub
Private Sub CreateInteriorColorList_ChkColumns(d As Object, a As Range)
Dim c As Range
For Each c In a.Columns
If IsNull(c.Interior.ColorIndex) Then
Call CreateInteriorColorList_ChkRows(d, c)
Else
CreateInteriorColorList_DicAdd d, c
End If
Next
End Sub
Private Sub CreateInteriorColorList_DicAdd(d As Object, ByVal a As Range)
Dim k As Long
k = a(1).Interior.ColorIndex
If (k And &HFF000000) = 0 Then k = a(1).Interior.Color
If d.Exists(k) Then Set d(k) = Union(d(k), a) Else Set d(k) = a
End Sub
Private Function Minus(Arg1 As Range, Arg2 As Range) As Range
Rem セル範囲Arg1からセル範囲Arg2を除くセル範囲を返す
If Arg1.Worksheet Is Arg2.Worksheet Then
Dim r As Collection
Set r = MinusRects(Range2Rect(Arg1), Range2Rect(Arg2))
If r.Count > 0 Then Set Minus = Rect2Range(r, Arg1.Worksheet)
Else
Set Minus = Arg1
End If
End Function
Private Function Range2Rect(Arg1 As Range) As Collection
Rem セル範囲Arg1を矩形集合に変換して返す
Dim r As clsRect, a As Range, cRects As New Collection
For Each a In Arg1.Areas
Set r = New clsRect
r.Top = a.Row
r.Left = a.Column
r.Bottom = r.Top + a.Rows.Count - 1
r.Right = r.Left + a.Columns.Count - 1
cRects.Add r
Next
Set Range2Rect = cRects
End Function
Private Function Rect2Range(Arg1 As Collection, Optional ByVal ParentSheet As Worksheet) As Range
Rem 矩形集合Arg1をセル範囲に変換して返す
Dim r As Range, i As Long, e As Long
If ParentSheet Is Nothing Then Set ParentSheet = ActiveSheet
'Debug.Print "Rect2Range result --------------------"
For i = 1 To Arg1.Count
On Error Resume Next
With ParentSheet
Set r = Range(.Cells(Arg1.Item(i).Top, Arg1.Item(i).Left), .Cells(Arg1.Item(i).Bottom, Arg1.Item(i).Right))
End With
e = Err.Number
On Error GoTo 0
If e = 0 Then
If Rect2Range Is Nothing Then Set Rect2Range = r Else Set Rect2Range = Union(Rect2Range, r)
End If
'Debug.Print i; Arg1.Item(i).ToAddress; " => ";
'If Not Rect2Range Is Nothing Then Debug.Print Rect2Range.Address(0, 0);
'Debug.Print
Next
End Function
Private Function MinusRects(Rects1 As Collection, Rects2 As Collection) As Collection
Rem 矩形集合1内の各矩形から矩形集合2内の各矩形を除いた矩形集合を作って返す
Dim r As Collection, i As Long
Set r = New Collection
For i = 1 To Rects1.Count
r.Add Rects1.Item(i)
Next
For i = 1 To Rects2.Count
'Debug.Print "Minus ["; Rects2.Item(i).ToAddress; "] ---------------------"
Set r = MinusRect_RSmR(r, Rects2.Item(i))
Next
Set MinusRects = r
End Function
Private Function MinusRect_RSmR(Rects1 As Collection, RectB As clsRect) As Collection
Rem 中継関数
Dim cRtn As Collection, i As Long
Dim iRect As clsRect
Dim cRects As New Collection, j As Long
For i = 1 To Rects1.Count
Set iRect = Rects1.Item(i)
'Debug.Print i, iRect.ToAddress; " - "; RectB.ToAddress
Set cRtn = MinusRect(iRect, RectB)
For j = 1 To cRtn.Count
'Debug.Print , j, cRtn.Item(j).ToAddress
cRects.Add cRtn.Item(j)
Next
Next
Set MinusRect_RSmR = cRects
End Function
Private Function MinusRect(RectA As clsRect, RectB As clsRect) As Collection
Rem 矩形Aから矩形Bを除いた矩形集合(行優先)を作って返す
Dim v As Collection, h As Collection, i As Long, j As Long
Dim r As clsRect, cRects As New Collection
Set v = LineDivider(RectA.Top, RectA.Bottom, RectB.Top, RectB.Bottom)
Set h = LineDivider(RectA.Left, RectA.Right, RectB.Left, RectB.Right)
For i = 1 To v.Count
If v(i)(2) Then
For j = 1 To h.Count
If Not h(j)(2) Then
Set r = New clsRect
r.Top = v(i)(0)
r.Bottom = v(i)(1)
r.Left = h(j)(0)
r.Right = h(j)(1)
cRects.Add r
End If
Next
Else
Set r = New clsRect
r.Top = v(i)(0)
r.Bottom = v(i)(1)
r.Left = RectA.Left
r.Right = RectA.Right
cRects.Add r
End If
Next
Set MinusRect = cRects
End Function
Private Function LineDivider(minA As Long, maxA As Long, minB As Long, maxB As Long) As Collection
Rem 区間Aを区間Bと重なる部分と重ならない部分に分割(配列(始点Long,終点Long,重なりBool)のコレクション)
Dim c As New Collection, Ary(0 To 2)
If maxB < minA Or minB > maxA Then '<---------重ならない
Ary(0) = minA: Ary(1) = maxA
Ary(2) = False
c.Add Ary
ElseIf minB <= minA And maxB >= maxA Then '<--Aの全区間が重なる
Ary(0) = minA: Ary(1) = maxA
Ary(2) = True
c.Add Ary
ElseIf minB > minA And maxB < maxA Then '<----Bの全区間が重なる
Ary(0) = minA: Ary(1) = minB - 1
Ary(2) = False
c.Add Ary
Ary(0) = minB: Ary(1) = maxB
Ary(2) = True
c.Add Ary
Ary(0) = maxB + 1: Ary(1) = maxA
Ary(2) = False
c.Add Ary
ElseIf maxB < maxA Then '<--------------------Aの途中まで重なる
Ary(0) = minA: Ary(1) = maxB
Ary(2) = True
c.Add Ary
Ary(0) = maxB + 1: Ary(1) = maxA
Ary(2) = False
c.Add Ary
ElseIf minB > minA Then '<--------------------Aの途中から重なる
Ary(0) = minA: Ary(1) = minB - 1
Ary(2) = False
c.Add Ary
Ary(0) = minB: Ary(1) = maxA
Ary(2) = True
c.Add Ary
End If
Set LineDivider = c
End Function
Rem --------------------------------------------------------------------------------------------------------------------
Function FuncColor3(arg As Range) As String '複数のエリアを引数にする場合は括弧()で引数を囲んで指定します。
Application.Volatile
Dim d As Object, v, r As Range, cmp As Range
Set d = CreateInteriorColorList(arg)
For Each v In d.Keys
If v <> xlColorIndexNone Then
If r Is Nothing Then Set r = d(v) Else Set r = Union(r, d(v))
End If
Next
If r Is Nothing Then Exit Function
Set r = r.EntireRow
Set cmp = Minus(r.Worksheet.Rows, r)
If Not cmp Is Nothing Then Set r = Minus(r.Worksheet.Rows, cmp)
FuncColor3 = r.Address
End Function
（白茶） 2023/10/31(火) 18:49:42
XYZ さん
ありがとうございます！まんま使わせてもらいました。大変参考＆勉強になりました。
白茶 さん
ありがとうございます！初心者なので解読に時間がかかりそうですが、勉強のためにも頑張ります！
（TK） 2023/10/31(火) 19:36:57
解決であれば無視してください。
>もう少し軽くする方法
体感できる効果はありましたか。 実際のセル範囲と抽出される行数はどのくらいでしょうか。 （マナ） 2023/10/31(火) 20:27:20
マナさん
セル範囲は100行程度で対象は１列。それをシート内のすべての列に対して計算する感じです。
抽出される行は多くて10程度かと思います。
列数・行数ともに今後使用していく中で増えていく予定なので、運用前に軽くしておきたいなと思い質問させてもらいました。
まだ運用前の状態なので、体感で軽くなったかはわからなかったですが、xyzさんからいただいた内容だとIf処理が一つ減るので、単純に軽くなるだろうなと思い、使わせていただきました。
皆様ありがとうございます。
（TK） 2023/11/01(水) 00:25:42
ありがとうございます。
> Application.Volatile
↑これは、必要ないのでは。
> セル範囲は100行程度
手抜きで、列全体を指定しちゃうと、かなりストレス感じますね。 （マナ） 2023/11/01(水) 09:06:50
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.