[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『重複区間』（エビアン）
以下のようにA列に開始値、B列に終了値があります。
値は0～1000の整数値となります。
開始～終了で重複した区間をC,D列に抽出したいです。
関数で可能なら、教えてください。
A B C D
1 開始 終了 重複開始 重複終了
2 600 689 660 689
3 660 719 735 779
4 665 669
5 720 779
6 750 869
7 735 764
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
（通りすがり） 2022/12/19(月) 11:32:30
>２行目のC、Dは、5行目のC、Dの間違いではありませんか？
行の見間違い。
3行目のC、Dは、5行目のC、Dの間違いではありませんか？ でした。 （MK） 2022/12/19(月) 13:11:06
やることの複雑さ考えると関数では無理なんじゃないかと。 マクロならなんとか。 （´・ω・`） 2022/12/19(月) 13:27:09
考え方的にはこんな感じでしょか?
Sub test()
Dim r As Range, u As Range
Union([A600:A689], [B660:B719], [C665:C669], [D720:D779], [E750:E869], [F735:F764]).Value = 1
With [G600:G869]
.FormulaR1C1 = "=SUM(RC1:RC6)"
For Each r In .Rows
If r.Value > 1 Then
If u Is Nothing Then Set u = r Else Set u = Union(u, r)
End If
Next
End With
For Each r In u.Areas
Debug.Print r.EntireRow.Address(False, False)
Next
End Sub
（白茶） 2022/12/19(月) 13:30:37
こう表現しても同じですね。 (まあ、考え方だけ何本も書いたって仕方ないんでしょうけど...^^; )
Sub test2()
Dim a As Long, b As Long
Dim u As Range, r As Range
With [600:689,660:719,665:669,720:779,750:869,735:764]
For a = 1 To .Areas.Count
For b = a + 1 To .Areas.Count
Set r = Intersect(.Areas(a), .Areas(b))
If Not r Is Nothing Then
If u Is Nothing Then Set u = r Else Set u = Union(u, r)
End If
Next
Next
End With
If Not u Is Nothing Then
For Each r In u.Areas
Debug.Print r.Address(0, 0)
Next
End If
End Sub
（白茶） 2022/12/19(月) 13:53:24
=LET(
_arry,HSTACK(VSTACK(テーブル1[開始],0),VSTACK(0,テーブル1[終了])),
_byr,VSTACK(FALSE,BYROW(_arry,LAMBDA(_a,INDEX(_a,2)<INDEX(_a,1)))),
_scn,CHOOSEROWS(SCAN(0,_byr,LAMBDA(_c,_d,_d+_c)),SEQUENCE(ROWS(_byr)-2,,2)),
_flg1,BYROW(HSTACK(_scn,テーブル1),LAMBDA(_e,SUM((_scn*INDEX(_e,1))*(テーブル1[開始]>=INDEX(_e,2))*(テーブル1[開始]<=INDEX(_e,3)))>1)),
_flg2,BYROW(HSTACK(_scn,テーブル1),LAMBDA(_e,SUM((_scn=INDEX(_e,1))*(テーブル1[終了]>=INDEX(_e,2))*(テーブル1[終了]<=INDEX(_e,3)))>1)),
_unq,UNIQUE(_scn),
_col1,BYROW(_unq,LAMBDA(_f,MAX(IF((_scn=_f)*_flg1,テーブル1[開始])))),
_col2,BYROW(_unq,LAMBDA(_g,MIN(IF((_scn=_g)*_flg2,テーブル1[終了])))),
VSTACK({"重複開始","重複終了"},HSTACK(_col1,_col2))
)
（d-q-t-p） 2022/12/19(月) 15:42:31
Option Explicit
Enum 表
開始列 = 1
終了列
重複開始列
重複終了列
タイトル行 = 1
End Enum
Sub test2()
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet
Dim 最終行 As Long: 最終行 = ws.Cells(Rows.count, 表.開始列).End(xlUp).Row
ws.Range(ws.Cells(表.タイトル行 + 1, 表.重複開始列), ws.Cells(最終行, 表.重複終了列)).Clear
ws.Copy
Dim Copywb As Workbook: Set Copywb = ActiveWorkbook
Dim Copyws As Worksheet: Set Copyws = ActiveSheet
Dim データ一覧: データ一覧 = データ加工して代入(Copyws, 最終行)
Copywb.Close savechanges:=False
Dim i As Long
Dim j As Long: j = 0
Dim 重複数 As Long: 重複数 = 0
For i = 1 To UBound(データ一覧, 1)
If データ一覧(i, 2) = "開始" Then
重複数 = 重複数 + 1
If 重複数 = 2 Then
j = j + 1
ws.Cells(表.タイトル行, 表.重複開始列).Offset(j) = データ一覧(i, 1)
End If
Else
重複数 = 重複数 - 1
If 重複数 = 1 Then
ws.Cells(表.タイトル行, 表.重複終了列).Offset(j) = データ一覧(i, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Function データ加工して代入(ws As Worksheet, 最終行 As Long) As Range
Dim データ数 As Long: データ数 = 最終行 - 表.タイトル行
ws.Cells(最終行 + 1, 表.開始列).Resize(データ数).Value = _
ws.Cells(表.タイトル行 + 1, 表.終了列).Resize(データ数).Value
ws.Cells(表.タイトル行 + 1, 表.終了列).Resize(データ数) = "開始"
ws.Cells(最終行 + 1, 表.終了列).Resize(データ数) = "終了"
With ws.Sort
With .SortFields
.Clear
.Add Key:=ws.Cells(表.タイトル行, 表.開始列), Order:=xlAscending
End With
.SetRange ws.Cells(表.タイトル行 + 1, 表.開始列).Resize(データ数 * 2, 2)
.Header = xlNo
.Apply
End With
Set データ加工して代入 = ws.Cells(表.タイトル行 + 1, 表.開始列).Resize(データ数 * 2, 2)
End Function
（ななし） 2022/12/19(月) 17:12:19
よく読んだら >値は0～1000の整数値 ってことだったので、 test2をゼロ値対応してFunction化してみたです。
Sub Test3()
Dim v
[A2:B7].Value = [{600,689;660,719;665,669;720,779;750,869;735,764}]
v = test4([A2:B7])
[C2:D2].Resize(UBound(v, 1)) = v
End Sub
Function test4(listRng As Variant) As Variant
Const ICHI = 1&
Dim v, rA As Range, rB As Range, rI As Range, rU As Range
Dim a As Long, b As Long
v = listRng 'Variant/Object/Rangeだった場合対策
For a = LBound(v, 1) To UBound(v, 1)
For b = a + 1 To UBound(v, 1)
Set rA = Range(Cells(v(a, 1) + ICHI, 1), Cells(v(a, 2) + ICHI, 1))
Set rB = Range(Cells(v(b, 1) + ICHI, 1), Cells(v(b, 2) + ICHI, 1))
Set rI = Intersect(rA, rB)
If Not rI Is Nothing Then
If rU Is Nothing Then Set rU = rI Else Set rU = Union(rU, rI)
End If
Next
Next
If rU Is Nothing Then Exit Function
ReDim v(1 To rU.Areas.Count, 1 To 2)
For a = 1 To rU.Areas.Count
v(a, 1) = rU.Areas(a).Row - ICHI
v(a, 2) = rU.Areas(a).Row + rU.Areas(a).Rows.Count - 1 - ICHI
Next
test4 = v
End Function
（白茶） 2022/12/19(月) 19:39:40
＞（白茶）様
test、test2、両方共、期待通りの結果を得られました。
test2は何をやっているか私には理解できませんが、testの方は理解できました。
＞（d-q-t-p）様
「すごすぎ」です。こんな壮大な数式になるとは思わなくて。
多分、自分のやり方が間違ってるんでしょうけど、表をテーブル化して試したんですけど
エラーとなりました。
自分で管理できるレベルを超えているので、今回はパスさせてください。
ごめんなさい。せっかく考えて下さったのに...
＞（ななし）様
期待通りの結果を得られました。
何をやっているか私には理解できませんが....
自分には（白茶）様のtestが一番理解しやすかったので、
今回はこれを採用させていただきます。
「行数分（例であれば6列）の作業列を用意して、0～1000の1001セルの連続範囲に「1」を代入して
各行の合計が「2以上」なら重複している」＜＝こういう事ですよね？
皆様、ありがとうございました。
おっと、ちんたら返信を書いている間に（白茶）様から、さらに返信いただいたみたいで...
自分には敷居が高そうなので、今後の参考とさせてください。
ありがとうございます。
（エビアン） 2022/12/19(月) 20:08:17
皆さんの力作を勉強させていただいています。
白茶さんの方法は直感的でいいですね。（直ぐには思いつきませんでした）
d-q-t-pさんの式による解法は、私の環境では試せないのですが、 随分と機能拡張されているのだと思わされます。 自由に変数を定義できたりするので、 大抵のことは式でできそうな気がしてきます。 関数型言語としての主要部品は揃った感じでしょうか。
ななしさんの解法も参考になりました。 ・開始、終了のイベントを、時刻順にソートしておき、 ・それぞれのイベントが発生したあとで、継続中の期間の数（「重複数」）を調べ、 ・それが増加して2になった時点が「重複開始」、 それが減少して1になった時点が「重複終了」 と判定する、 というものですね。
時刻 重複数 600 開始 1 660 開始 2 重複開始 665 開始 3 669 終了 2 689 終了 1 重複終了 719 終了 0 720 開始 1 735 開始 2 重複開始 750 開始 3 764 終了 2 779 終了 1 重複終了 869 終了 0
計算量は最小でしょうか。綺麗ですね。 Enumを使っていて、それに慣れないととっつきにくいかもしれないですが、 大いに参考になると思いました。 （γ） 2022/12/20(火) 10:44:49
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.