Results of 1 - 1 of about 37667 for IF (0.007 sec.)
- [[20231031004740]]
- #score: 1591
- @digest: cad58a1fdc18cfc2b5cd84d99c957e43
- @id: 95414
- @mdate: 2023-11-01T00:06:50Z
- @size: 14848
- @type: text/plain
- #keywords: createinteriorcolorlist (129320), clsrect (62720), dicadd (56043), crects (55646), rect2range (55147), minusrect (40599), 形集 (35559), chkarea (35340), rectb (31360), iarea (30814), toaddress (30077), rects1 (27823), linedivider (27823), range2rect (27823), lastcell (27714), recta (26361), parentsheet (25703), minb (25703), minus (23453), chkcolumns (21640), chkrows (21640), maxb (21079), unusedbr (21016), unusedb (21016), unusedr (21016), rects2 (20867), collection (20737), urect (19899), maxa (18118), 囲ar (18074), 矩形 (17019), mina (16654)
- 『背景色のある行番号を取得するユーザー定義関数』（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 ---- 思い付きで[[20220516124034]]と[[20231017153822]]を混ぜて遊んでみた。 ま場合によっては軽いかも知れませんけど「軽くする方法」って訳ではないですね ^^; 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行程度で対象は1列。それをシート内のすべての列に対して計算する感じです。 抽出される行は多くて10程度かと思います。 列数・行数ともに今後使用していく中で増えていく予定なので、運用前に軽くしておきたいなと思い質問させてもらいました。 まだ運用前の状態なので、体感で軽くなったかはわからなかったですが、xyzさんからいただいた内容だとIf処理が一つ減るので、単純に軽くなるだろうなと思い、使わせていただきました。 皆様ありがとうございます。 （TK） 2023/11/01(水) 00:25:42 ---- ありがとうございます。 > Application.Volatile ↑これは、必要ないのでは。 > セル範囲は100行程度 手抜きで、列全体を指定しちゃうと、かなりストレス感じますね。 （マナ） 2023/11/01(水) 09:06:50... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202310/20231031004740.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：