[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA: 2つのセル範囲で重なっていない範囲の取得』（VBA勉強中）
VBAで2つの範囲に対し、重なっている範囲を取得するにはIntersectを用いればよいかと思いますが、逆に重なっていない範囲を取得するにはどういう方法が考えられるでしょうか？
具体的には以下のような状況を想定しております。
rng1 = Range("A1:C5")
rng2 = Range("C1:D5")
上記のとき、rng1とrng2の重なっていないRange("A1:B5")およびRange("D1:D5")を取得したいです。
よろしくお願いします。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
かぶってますが...Union かこんな意味ですか？
Dim MyRNG As Range
Set MyRNG = Range("A1:B5,D1:D5")
If Intersect(Target, MyRNG) Is Nothing Then Exit Sub （あみな） 2022/05/16(月) 13:11
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1191798316
（わからん） 2022/05/16(月) 13:19
わからん様
参考になるページを教えていただきありがとうございます！
一通り調べてみたつもりでしたが、お教えいただいたページにはたどり着けておりませんでした。。
引き続き勉強を進めていきます。ありがとうございました。
（VBA勉強中） 2022/05/16(月) 13:39
一時的に作業用ワークシートを追加したらどうでしょう
Sub sample()
Dim rng1 As Range, rng2 As Range
Set rng1 = Range("A1:C5")
Set rng2 = Range("C1:D5")
SymmetricDiff(rng1, rng2).Select
End Sub
Function SymmetricDiff(ByVal r1 As Range, ByVal r2 As Range) As Range
Dim uRng As Range, iRng As Range
Set uRng = Union(r1, r2)
Set iRng = Intersect(r1, r2)
If iRng Is Nothing Then
Set SymmetricDiff = uRng
Exit Function
End If
Set tmpws = Worksheets.Add
Set uRng = tmpws.Range(uRng.Address)
Set iRng = tmpws.Range(iRng.Address)
uRng.Value = 1
iRng.ClearContents
Set SymmetricDiff = uRng.SpecialCells(xlCellTypeConstants)
Set SymmetricDiff = r1.Parent.Range(SymmetricDiff.Address)
Application.DisplayAlerts = False
tmpws.Delete
Application.DisplayAlerts = True
End Function
（´・ω・`） 2022/05/16(月) 13:49
勉強のため皆さまにいただいた例をそれぞれ実装して差を比較したいと思います。
ありがとうございました。
（VBA勉強中） 2022/05/16(月) 14:19
エヘヘ。遅れ馳せながら...^^;
リンク先にも感化され、真正面から取り組んだらどうなるかちょっと考えてみたくなりました。 「Union、Intersectがあって、SQLみたく『Minus』が無いから作ってみよう」ってお題で暇つぶし。
式
Function Minus(Arg1 As Range, Arg2 As Range) As Range
機能
Arg1にあってArg2に無い範囲を返す => Arg1からArg2を除く範囲を返す
方針 UnionやIntersectの様な[Arg3]～[Arg30]部分はMinus処理には不要だと思われる。 但し、Arg1、Arg2共に複数Areaから成るRangeにも対応させる。 各引数内の各Areaを「矩形オブジェクト」と考え、そのコレクションとして扱って計算してみようと思う。
'[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
'以下、標準モジュールの話--------------------------------------------------------------------------
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
'Minusメソッド使用例 ------------------------------------------------------------------------------
Sub 選択範囲の除去()
If ActiveWorkbook Is Nothing Then Exit Sub
If TypeName(Selection) <> "Range" Then Exit Sub
Dim Ra As Range
On Error Resume Next
Set Ra = Application.InputBox("現在の選択範囲と交わる範囲を選択して下さい。", Title:="除去する範囲の選択", Type:=8)
On Error GoTo 0
If Ra Is Nothing Then Exit Sub
Set Ra = Minus(ActiveWindow.RangeSelection, Ra)
If Ra Is Nothing Then
MsgBox "選択範囲が全滅します。", vbCritical
Exit Sub
End If
Ra.Select
End Sub
Sub 動作確認()
Dim Ra As Range, Rb As Range
Set Ra = [A4:G6,B1:F9]
Ra.Select
Set Rb = [C2:D2,C5:D7]
Debug.Print "▼["; Ra.Address(0, 0); "] - ["; Rb.Address(0, 0); "]"
Set Ra = Minus(Ra, Rb)
Debug.Print "■ => ["; Ra.Address(0, 0); "]"
Ra.Select
End Sub
Sub 重なっていない範囲の取得テスト()
Dim Ra As Range, Rb As Range, Rc As Range
Set Ra = [A1:C5]
Set Rb = [C1:D5]
Set Rc = Minus(Union(Ra, Rb), Intersect(Ra, Rb))
Debug.Print Rc.Address(0, 0)
End Sub
（白茶） 2022/05/20(金) 20:15
あ。 もうひとつ使い道思い付いたのでメモ ^^;
Minus(Cells, Minus(Cells, 範囲)) で、 順番や重複がぐちゃぐちゃした範囲をキレイに整えられますね。
例
[B5:F5,D5:D19,B9:B19,F9:F19,B13:F14,B5:F6]
↓
[B5:F6,B9:B12,D7:D12,F9:F12,B13:F14,B15:B19,D15:D19,F15:F19]
（白茶） 2022/05/21(土) 17:59
Function RangeN(領域 As Range) As Dictionary
Dim dic As New Dictionary
Dim WA As Range
Dim i As Long
Dim W1 As Variant
Dim wK As Variant
For Each WA In 領域.Areas
For Each W1 In WA.Cells
Select Case dic.Exists(W1.Address)
Case True: dic(W1.Address) = Empty
Case Else: dic.Add W1.Address, W1
End Select
Next
Next
For Each wK In dic.Keys
If IsEmpty(dic(wK)) Then dic.Remove wK
Next
Set RangeN = dic
End Function
Sub test()
Dim x As Variant
Dim W9 As Range
Dim 範囲 As Range
' Set 範囲 = Range("A1:C5,C1:D5,A2:E3")
Set 範囲 = Range("A1:C5,C1:D5")
'(1) --各要素へのアクセスだけなら ↓ な感じで
For Each x In RangeN(範囲).Items
Debug.Print x.Address; x.Value
Next
'(2)敢えてRangeがほしいなら
For Each x In RangeN(範囲).Items
If W9 Is Nothing Then Set W9 = x Else Set W9 = Union(W9, x)
Next
Debug.Print W9.Address
End Sub
（チオチモリン） 2022/05/21(土) 23:22
>rng1 = Range("A1:C5")
>rng2 = Range("C1:D5")
>上記のとき、rng1とrng2の重なっていないRange("A1:B5")およびRange("D1:D5")を取得したいです。
なら ↓ のようでしょうか
Sub test2()
Dim rng1 As Range
Dim rng2 As Range
Dim W9 As Range
Set rng1 = Range("A1:C5")
Set rng2 = Range("C1:D5")
MsgBox RangeN2(rng1, rng2).Address
MsgBox RangeN2(rng1, rng2, Range("A2:E3")).Address
End Sub
Function RangeN2(ParamArray 領域() As Variant) As Range
Dim dic As New Dictionary
Dim i As Long
Dim W1 As Variant
Dim wK As Variant
Dim W9 As Range
For i = 0 To UBound(領域)
For Each W1 In 領域(i).Cells
Select Case dic.Exists(W1.Address)
Case True: dic(W1.Address) = Empty
Case Else: dic.Add W1.Address, W1
End Select
Next
Next
For Each wK In dic.Keys
If IsEmpty(dic(wK)) = False Then
If W9 Is Nothing Then Set W9 = dic(wK) Else Set W9 = Union(W9, dic(wK))
End If
Next
Set RangeN2 = W9
End Function
（チオチモリン） 2022/05/23(月) 09:33
(独り言です。スルー希望 ^^; )
なんか神髄さんで似たような話題を見つけてしまった...
Rangeオブジェクトの論理演算（差集合と排他的論理和）｜VBA技術解説
https://excel-ubara.com/excelvba4/EXCEL_VBA_425.html
Union 和集合 Intersect 積集合 Except 差集合 (今回の「Minus」) Complement 補集合 (「Not(範囲)」的な...)
Except([A], [B]) = Intersect([A], Complement([B])) なので 「Complementを作ってみよう」で話を進めても良かったかも知れない。 (引数範囲の上下左右に存在する矩形集合を返す。という)
でも Complement([B]) = Except(Cells, [B]) だから Complementを作る作業って結局Exceptを作る作業とほとんど概念が同じなのね。
やっぱ「Exceptを作ってみよう」で良かったんだろう。(としておこう)
＊ ＊ ＊
しかしComplementも案外使えるかもなぁ... 単独で使用する機能ではないだろうけど、 PhotoShop等の画像処理系では「選択範囲の反転」機能は必須で、 例えば[反転]→[調整]→[反転]という流れは常套手段だし。
「○○なセル範囲」を取得する機能を持っていれば、 「○○以外なセル範囲」を取得する機能も間接的に実装出来ちゃう訳で。 (例:空白セル以外とか、数式セル以外、この色以外とか...) ちょっと試験配備ですな
（白茶） 2022/05/26(木) 10:57
重なった所の文字消す。
です。
（甲樹） 2022/05/26(木) 17:03
>これじゃダメ？ もちろんアリだと思います。 （´・ω・`）さんの 2022/05/16(月) 13:49 の様な手法ですよね。
別に否定してる訳じゃなくって、 何ていうか、もう少しオタクっぽい話なんすね。
範囲選択の話なんだから「何かの最中」に必要となるであろう機能なのにも関わらず、 ただ範囲選択するだけでUnDoリスト破棄されたり裏で無駄なイベントが投げ込まれたりされちゃう手法を 自ら選ぶ気には到底なれない。とか ましてそんな機能を自分が使うアドインに組み込むなんで我慢ならない。とか...
これに関しては汎用化を想定するにあたって正攻法を採らないと気が済まなかったんですね。 (実際使う時にはホントどうでもいいことなんですけどね!!) ま、めんどくせー奴なんすよ^^;
# 解決後にウダウダとしつこく書かせて頂いた身として責任を感じたのでスルー出来ませんでした。 # 「別にあんたに訊いてないよ」って場合はご容赦下さい。
（白茶） 2022/05/26(木) 19:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.