Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7808 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【36725】複数の長方形における干渉をチェックするマクロについて しとうと 06/4/10(月) 22:55 質問[未読]
【36728】Re:複数の長方形における干渉をチェックす... ちくたく 06/4/11(火) 10:22 発言[未読]
【36729】Re:複数の長方形における干渉をチェックす... しろうと 06/4/11(火) 10:51 発言[未読]
【36731】Re:複数の長方形における干渉をチェック... わいわい 06/4/11(火) 11:33 発言[未読]
【36733】Re:複数の長方形における干渉をチェック... ちくたく 06/4/11(火) 11:57 発言[未読]
【36738】Re:複数の長方形における干渉をチェック... ハト 06/4/11(火) 16:01 発言[未読]
【36739】Re:複数の長方形における干渉をチェック... ちくたく 06/4/11(火) 16:31 発言[未読]
【36740】Re:複数の長方形における干渉をチェック... ハト 06/4/11(火) 17:05 発言[未読]
【36747】Re:複数の長方形における干渉をチェック... ハト 06/4/12(水) 8:09 発言[未読]
【36741】Re:複数の長方形における干渉をチェック... こたつねこ 06/4/11(火) 17:41 発言[未読]
【36742】Re:複数の長方形における干渉をチェック... ハト 06/4/11(火) 18:06 発言[未読]
【36744】Re:複数の長方形における干渉をチェック... こたつねこ 06/4/11(火) 18:30 発言[未読]
【36736】Re:複数の長方形における干渉をチェックす... こたつねこ 06/4/11(火) 15:13 回答[未読]
【36745】Re:複数の長方形における干渉をチェックす... ichinose 06/4/11(火) 21:42 発言[未読]
【36746】Re:複数の長方形における干渉をチェックす... 平塚在住 06/4/11(火) 22:37 回答[未読]
【36725】複数の長方形における干渉をチェックする...
質問  しとうと  - 06/4/10(月) 22:55 -
引用なし
パスワード
   次のようなマクロを作成することは可能でしょうか？
もし，どなたかお分かりになる人がいらっしゃいましたら，
教えていただけないでしょうか？


xy平面において，中心と縦横長さが異なる50個の長方形があります。

この長方形の名称，中心座標のx座標，ｙ座標，縦(x方向)の長さ，縦(y方向）の長さが
それぞれE列，F列，G列，I列，J列の17行目から66行目まで記入されています。

このとき，長方形同士が，接触または重なりあうものがある場合には，該当する長方形
の名称のセル（E列）の背景を黄色に変更したいのです。

但し，接触または重なりあうかどうかを調査したい長方形のD列のセルには，数字の「1」
が記入されており，すべての長方形について，調査するのではなく，この「1」が記入されて
いる行の長方形についてのみ，調査したいです。

また，1組でも，接触または重なり合う長方形が見つかった時点で，該当する長方形の名称の
セル（E列）の背景を黄色に変更し，マクロはストップしたいです。

以上，よろしくお願い致します。
【36728】Re:複数の長方形における干渉をチェック...
発言  ちくたく  - 06/4/11(火) 10:22 -
引用なし
パスワード
   しとうと さん
こんにちは。

>このとき，長方形同士が，接触または重なりあうものがある場合には，該当する長方形
>の名称のセル（E列）の背景を黄色に変更したいのです。

AutoCADをもってらっしゃいませんか？
それなら、交差の検出が機能であるので、できるのですが。。。

Excel単体でも、できると思うのですが、
コードが思いつきません。
ちょっと考えてみます。
【36729】Re:複数の長方形における干渉をチェック...
発言  しろうと  - 06/4/11(火) 10:51 -
引用なし
パスワード
   ちくたく さん へ

ご回答ありがとうございます。

>AutoCADをもってらっしゃいませんか？

残念ながら，AutoCADは持っておりません。

自分でも考えてみたのですが，うまく機能致しません。

以下に記載させて頂きます。

もし，訂正箇所がございましたら，ご指摘いただけると幸いです。

以上，よろしくお願い致します。

Sub Check_contact()

Dim N, M, ans As Integer
Dim AminX, AmaxX, AminY, AmaxY, BminX, BmaxX, BminY, BmaxY As Single
Dim msglist(0) As String

　　msglist(0) = "長方形同士が接触している可能性があります。" & vbCrLf & vbCrLf & _
　　　　　　　　 "該当長方形の名称のセル背景は黄色で表示されています。 " & vbCrLf & vbCrLf & _
　　　　　　　　 "該当長方形の[中心座標]および[サイズ] の数値を" & vbCrLf & _
　　　　　　　　 "再チェックし，正しい数値を入力してください。"

'A:元の長方形,B:比較対象の長方形
　　
For N = 17 To 65
If Cells(N, 4) = 1 Then 'if1
　For M = N + 1 To 66
　　If Cells(M, 4) = 1 Then 'if2
　　
　　 AminX = Cells(N, 6).value - Cells(N, 9).value / 2
　　 AmaxX = Cells(N, 6).value + Cells(N, 9).value / 2
　　 BminX = Cells(M, 6).value - Cells(M, 9).value / 2
　　 BmaxX = Cells(M, 6).value + Cells(M, 9).value / 2

　　 AminY = Cells(N, 7).value - Cells(N, 10).value / 2
　　 AmaxY = Cells(N, 7).value + Cells(N, 10).value / 2
　　 BminY = Cells(M, 7).value - Cells(M, 10).value / 2
　　 BmaxY = Cells(M, 7).value + Cells(M, 10).value / 2

　　 If AminX <= BminX <= AmaxX Then 'if3
　　　
　　　　 If AminY <= BminY <= AmaxY Then 'if4
　　　
　　　　　 Cells(N, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　　　 Cells(M, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　
　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
　　　　　End
　　　　
　　　　 ElseIf AminY <= BmaxY <= AmaxY Then 'if4
　　　
　　　　　 Cells(N, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　　　 Cells(M, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　
　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
　　　　　End
　　　　　
　　　　 End If 'if4
　　
　　 End If 'if3
　　
　　 If AminX <= BmaxX <= AmaxX Then 'if5
　　　
　　　 If AminY <= BminY <= AmaxY Then 'if6
　　　
　　　　　 Cells(N, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　　　 Cells(M, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　
　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
　　　　　End
　　　　
　　　 ElseIf AminY <= BmaxY <= AmaxY Then 'if6
　　　
　　　　　 Cells(N, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　　　 Cells(M, 5).Select
　　　　　　 With Selection.Interior
　　　　　　 .ColorIndex = 36
　　　　　　 .Pattern = xlSolid
　　　　　 End With
　　　
　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
　　　　　End
　　　　　
　　　 End If 'if6
　　　
　　 End If 'if5
　　
　　End If 'if2
　Next M
End If 'if1
Next N

End Sub
【36731】Re:複数の長方形における干渉をチェック...
発言  わいわい  - 06/4/11(火) 11:33 -
引用なし
パスワード
   しろうと さん へ
こんにちは、回答になるか分かりませんが気になった点をいくつか
ＩＦ文についてなんですが
>If AminY <= BminY <= AmaxY Then
 If AminY <= BminY And BminY<= AmaxY Then としたら良いのではないでしょうか？
次に、四角の干渉条件ですが、
BminX<AminX かつ BmaxX>AmaxX かつ BminY>AminY かつ BmaxY<AmaxY と
BminX>AminX かつ BmaxX<AmaxX かつ BminY<AminY かつ BmaxY>AmaxY の（貫通といったらよいのか分かりませんが）条件が抜けているのではないですか？

>ちくたく さん へ
>
>ご回答ありがとうございます。
>
>>AutoCADをもってらっしゃいませんか？
>
>残念ながら，AutoCADは持っておりません。
>
>自分でも考えてみたのですが，うまく機能致しません。
>
>以下に記載させて頂きます。
>
>もし，訂正箇所がございましたら，ご指摘いただけると幸いです。
>
>以上，よろしくお願い致します。
>
>Sub Check_contact()
>
>Dim N, M, ans As Integer
>Dim AminX, AmaxX, AminY, AmaxY, BminX, BmaxX, BminY, BmaxY As Single
>Dim msglist(0) As String
>
>　　msglist(0) = "長方形同士が接触している可能性があります。" & vbCrLf & vbCrLf & _
>　　　　　　　　 "該当長方形の名称のセル背景は黄色で表示されています。 " & vbCrLf & vbCrLf & _
>　　　　　　　　 "該当長方形の[中心座標]および[サイズ] の数値を" & vbCrLf & _
>　　　　　　　　 "再チェックし，正しい数値を入力してください。"
>
>'A:元の長方形,B:比較対象の長方形
>　　
>For N = 17 To 65
> If Cells(N, 4) = 1 Then 'if1
>　For M = N + 1 To 66
>　　If Cells(M, 4) = 1 Then 'if2
>　　
>　　 AminX = Cells(N, 6).value - Cells(N, 9).value / 2
>　　 AmaxX = Cells(N, 6).value + Cells(N, 9).value / 2
>　　 BminX = Cells(M, 6).value - Cells(M, 9).value / 2
>　　 BmaxX = Cells(M, 6).value + Cells(M, 9).value / 2
>
>　　 AminY = Cells(N, 7).value - Cells(N, 10).value / 2
>　　 AmaxY = Cells(N, 7).value + Cells(N, 10).value / 2
>　　 BminY = Cells(M, 7).value - Cells(M, 10).value / 2
>　　 BmaxY = Cells(M, 7).value + Cells(M, 10).value / 2
>
>　　 If AminX <= BminX <= AmaxX Then 'if3
>　　　
>　　　　 If AminY <= BminY <= AmaxY Then 'if4
>　　　
>　　　　　 Cells(N, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　　　 Cells(M, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　
>　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
>　　　　　End
>　　　　
>　　　　 ElseIf AminY <= BmaxY <= AmaxY Then 'if4
>　　　
>　　　　　 Cells(N, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　　　 Cells(M, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　
>　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
>　　　　　End
>　　　　　
>　　　　 End If 'if4
>　　
>　　 End If 'if3
>　　
>　　 If AminX <= BmaxX <= AmaxX Then 'if5
>　　　
>　　　 If AminY <= BminY <= AmaxY Then 'if6
>　　　
>　　　　　 Cells(N, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　　　 Cells(M, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　
>　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
>　　　　　End
>　　　　
>　　　 ElseIf AminY <= BmaxY <= AmaxY Then 'if6
>　　　
>　　　　　 Cells(N, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　　　 Cells(M, 5).Select
>　　　　　　 With Selection.Interior
>　　　　　　 .ColorIndex = 36
>　　　　　　 .Pattern = xlSolid
>　　　　　 End With
>　　　
>　　　　　ans = MsgBox(msglist(0), 65552, "パラメータ設定エラー")
>　　　　　End
>　　　　　
>　　　 End If 'if6
>　　　
>　　 End If 'if5
>　　
>　　End If 'if2
>　Next M
> End If 'if1
>Next N
>
>End Sub
【36733】Re:複数の長方形における干渉をチェック...
発言  ちくたく  - 06/4/11(火) 11:57 -
引用なし
パスワード
   しろうと さん 、わいわい さん
こんにちは。

コードにしてみたんですけど、
正直、合ってるのか間違ってるのかわからないので、
検証をお願いします。
コメント入れてるので、なんとかわかって頂けたらと思います。
これが合ってたら、処理の速さは考えなければ、
ループを回すだけなんですけどね。

Sub test()

　　Dim rectA(1 To 4) As Double, rectB(1 To 4) As Double
　　Dim i As Integer, f As Boolean
　　
　　i = 17
　　f = False
　　
　　'rectA、rectBを四角形とし、それぞれの上下左右の座標値を格納
　　
　　rectA(1) = Range("F" & i) + Range("I" & i) / 2　'右
　　rectA(2) = Range("F" & i) - Range("I" & i) / 2　'左
　　rectA(3) = Range("G" & i) + Range("J" & i) / 2　'上
　　rectA(4) = Range("G" & i) - Range("J" & i) / 2　'下
　　
　　i = i + 1
　　
　　rectB(1) = Range("F" & i) + Range("I" & i) / 2　'右
　　rectB(2) = Range("F" & i) - Range("I" & i) / 2　'左
　　rectB(3) = Range("G" & i) + Range("J" & i) / 2　'上
　　rectB(4) = Range("G" & i) - Range("J" & i) / 2　'下
　　
　　'rectAに対するrectBの位置を検査
　　
　　'きれいなコードではないけれど、If文でひとつずつ精査していくこととする。
　　
　　'まずは、rectAに対し、上が含まれる可能性があるか。
　　'rectBの上がrectAの上よりも下であり、かつ、rectAの下よりも上であること
　　If rectB(3) <= rectA(3) And rectB(3) >= rectA(4) Then
　　　　　f = True
　　End If
　　
　　'次に、rectAに対し、下が含まれる可能性があるか。
　　'rectBの下がrectAの下よりも上であり、かつ、rectAの上よりも下であること
　　If rectB(4) <= rectA(4) And rectB(4) >= rectA(3) Then
　　　　　f = True
　　End If
　　
　　'フラグに引っかかってたら、横についての検査。
　　If f = True Then
　　　　'まずは、rectAに対し、左が含まれる可能性があるか。
　　　　'rectBの左がrectAの左よりも右であり、かつ、rectAの右よりも左であること。
　　　　If rectB(2) >= rectA(2) And rectB(2) <= rectA(1) Then
　　　　　　MsgBox ("交差しています")
　　　　End If
　　　　
　　　　'次に、rectAに対し、右が含まれる可能性があるか。
　　　　'rectBの右がrectAの右よりも左であり、かつ、rectAの左よりも右であること。
　　　　If rectB(1) <= rectA(1) And rectB(1) >= rectA(2) Then
　　　　　　MsgBox ("交差しています")
　　　　End If
　　End If
　　
End Sub
【36736】Re:複数の長方形における干渉をチェック...
回答  こたつねこ  - 06/4/11(火) 15:13 -
引用なし
パスワード
   みなさん、こんにちは

しとうとさんの参考になればいいのですが・・・
細かな仕様を把握していませんので、動作が違う場合は
ご指摘ください。


'--構造体定義 STR--
Type BoxInfo　　　　'四角形の構造体情報
　　CX As Double　　'中心座標Ｘ
　　CY As Double　　'中心座標Ｙ
　　XX As Double　　'長さＸ
　　YY As Double　　'長さＹ
End Type
'--構造体定義 END--

Sub Check_contact()
　　Dim box1 As BoxInfo
　　Dim box2 As BoxInfo
　　Dim N As Integer
　　Dim M As Integer
　　
　　For N = 17 To 65
　　　　If Cells(N, 5).Value = 1 Then
　　　　　　'--四角形情報を関連セルより取得 STR--
　　　　　　With box1
　　　　　　　　.CX = Cells(N, 6).Value
　　　　　　　　.CY = Cells(N, 7).Value
　　　　　　　　.XX = Cells(N, 8).Value
　　　　　　　　.YY = Cells(N, 9).Value
　　　　　　End With
　　　　　　'--四角形情報を関連セルより取得 END--
　　　　　　
　　　　　　For M = N + 1 To 66
　　　　　　　　If Cells(M, 5).Value = 1 Then
　　　　　　　　　　'--四角形情報を関連セルより取得 STR--
　　　　　　　　　　With box2
　　　　　　　　　　　　.CX = Cells(M, 6).Value
　　　　　　　　　　　　.CY = Cells(M, 7).Value
　　　　　　　　　　　　.XX = Cells(M, 8).Value
　　　　　　　　　　　　.YY = Cells(M, 9).Value
　　　　　　　　　　End With
　　　　　　　　　　'--四角形情報を関連セルより取得 END--
　　　　　　　　　　
　　　　　　　　　　'２つの四角形が重なり合うか？
　　　　　　　　　　If intervention(box1, box2) Then
　　　　　　　　　　　　'--重なる場合はセルに色づけ STR--
　　　　　　　　　　　　With Cells(N, 5).Interior
　　　　　　　　　　　　　　.ColorIndex = 36
　　　　　　　　　　　　　　.Pattern = xlSolid
　　　　　　　　　　　　End With
　　　　　　　　　　　　
　　　　　　　　　　　　With Cells(M, 5).Interior
　　　　　　　　　　　　　　.ColorIndex = 36
　　　　　　　　　　　　　　.Pattern = xlSolid
　　　　　　　　　　　　End With
　　　　　　　　　　　　'--重なる場合はセルに色づけ END--
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
End Sub

'------------------------------------
'■２つの四角形が重なるか判定する関数
'引数１：box1
'引数２：box2
'戻り値：True =重なる
'　　　：Flase=重ならない
'------------------------------------
Function intervention(ByRef box1 As BoxInfo, ByRef box2 As BoxInfo) As Boolean
　　'--比較元用座標情報格納用変数 STR--
　　Dim bx1 As Double
　　Dim bx2 As Double
　　Dim by1 As Double
　　Dim by2 As Double
　　'--比較元用座標情報格納用変数 END--
　　
　　'--比較先用座標情報格納用変数 STR--
　　Dim cx1 As Double
　　Dim cx2 As Double
　　Dim cy1 As Double
　　Dim cy2 As Double
　　'--比較先用座標情報格納用変数 END--
　　
　　'Ｘ軸方向に長い値を比較元に
　　'　　　　　短い値を比較先にセット
　　If box1.XX > box2.XX Then
　　　　Call setX(box1, bx1, bx2)
　　　　Call setX(box2, cx1, cx2)
　　Else
　　　　Call setX(box2, bx1, bx2)
　　　　Call setX(box1, cx1, cx2)
　　End If
　　
　　'比較元のＸ軸座標の範囲に比較先のＸ軸座標が含まれているか計算
　　intervention = (bx1 <= cx1 And cx1 <= bx2) Or (bx1 <= cx2 And cx2 <= bx2)
　　
　　'含まれていないので処理を抜ける
　　If intervention = False Then Exit Function
　　
　　'Ｙ軸方向に長い値を比較元に
　　'　　　　　短い値を比較先にセット
　　If box1.YY > box2.YY Then
　　　　Call setY(box1, by1, by2)
　　　　Call setY(box2, cy1, cy2)
　　Else
　　　　Call setY(box2, by1, by2)
　　　　Call setY(box1, cy1, cy2)
　　End If
　　
　　'比較元のＹ軸座標の範囲に比較先のＹ軸座標が含まれているか計算
　　intervention = (by1 <= cy1 And cy1 <= by2) Or (by1 <= cy2 And cy2 <= by2)
End Function

'------------------------
'■Ｘ座標をセットする処理
'------------------------
Sub setX(ByRef typebox As BoxInfo, x1 As Double, x2 As Double)
　　With typebox
　　　　x1 = .CX - .XX / 2
　　　　x2 = .CX + .XX / 2
　　End With
End Sub

'------------------------
'■Ｙ座標をセットする処理
'------------------------
Sub setY(ByRef typebox As BoxInfo, y1 As Double, y2 As Double)
　　With typebox
　　　　y1 = .CY - .YY / 2
　　　　y2 = .CY + .YY / 2
　　End With
End Sub
【36738】Re:複数の長方形における干渉をチェック...
発言  ハト  - 06/4/11(火) 16:01 -
引用なし
パスワード
   みなさん
こんにちは。

>
>コードにしてみたんですけど、
>正直、合ってるのか間違ってるのかわからないので、
>検証をお願いします。

>　　
>　　'まずは、rectAに対し、上が含まれる可能性があるか。
>　　'rectBの上がrectAの上よりも下であり、かつ、rectAの下よりも上であること
>　　If rectB(3) <= rectA(3) And rectB(3) >= rectA(4) Then
>　　　　　f = True
>　　End If
>　　
>　　'次に、rectAに対し、下が含まれる可能性があるか。
>　　'rectBの下がrectAの下よりも上であり、かつ、rectAの上よりも下であること
>　　If rectB(4) <= rectA(4) And rectB(4) >= rectA(3) Then
>　　　　　f = True
>　　End If
この比較ですとＢの四角形の中にＡの四角形が内包されるケースがひっかかりません
以下の様にしてみたらどうでしょうか？
　　’Ｂの上がＡの下よりも下にあるかＢの下がＡの上よりも上にあれば重ならない
　　If rectB(3) < rectA(4) Or rectB(4) > rectA(3) Then
　　　　f = False
　　Else
　　　　f = True
　　End if

>　　'フラグに引っかかってたら、横についての検査。
>　　If f = True Then
>　　　　'まずは、rectAに対し、左が含まれる可能性があるか。
>　　　　'rectBの左がrectAの左よりも右であり、かつ、rectAの右よりも左であること。
>　　　　If rectB(2) >= rectA(2) And rectB(2) <= rectA(1) Then
>　　　　　　MsgBox ("交差しています")
>　　　　End If
>　　　　
>　　　　'次に、rectAに対し、右が含まれる可能性があるか。
>　　　　'rectBの右がrectAの右よりも左であり、かつ、rectAの左よりも右であること。
>　　　　If rectB(1) <= rectA(1) And rectB(1) >= rectA(2) Then
>　　　　　　MsgBox ("交差しています")
>　　　　End If
>　　End If
>　　
>End Sub
比較については上の記述したのと同様です。
それとこの記述の場合、Ｂの左右共にＡの左右内にある場合、２度メッセージが出る事になりますので、１回目のメッセージ出力後に　Exit Sub　の記述をした方がよいと思われます。
【36739】Re:複数の長方形における干渉をチェック...
発言  ちくたく  - 06/4/11(火) 16:31 -
引用なし
パスワード
   ハト さん、みなさん。
こんにちは。

どうも、こういうクイズみたいな構造は苦手です。
こたつねこさんが回答されてるみたいですが、一応。
下記のコードでどうでしょう。速度は考慮してませんし、
合ってるのかわからないから、エラー処理もしてません。
間違っているような気もして恥ずかしいのですが。

Sub test2()

　　Dim rectA(1 To 4) As Double, rectB(1 To 4) As Double
　　Dim i As Integer, j As Integer
　　
　　For i = 17 To 66
　　
　　　　'rectA、rectBを四角形とし、それぞれの上下左右の座標値を格納
　　　　
　　　　rectA(1) = Range("F" & i) + Range("I" & i) / 2　'右
　　　　rectA(2) = Range("F" & i) - Range("I" & i) / 2　'左
　　　　rectA(3) = Range("G" & i) + Range("J" & i) / 2　'上
　　　　rectA(4) = Range("G" & i) - Range("J" & i) / 2　'下
　　

　　　　For j = i + 1 To 66
　　　　　　rectB(1) = Range("F" & j) + Range("I" & i) / 2　'右
　　　　　　rectB(2) = Range("F" & j) - Range("I" & i) / 2　'左
　　　　　　rectB(3) = Range("G" & j) + Range("J" & i) / 2　'上
　　　　　　rectB(4) = Range("G" & j) - Range("J" & i) / 2　'下
　　　　
　　　　　　'rectAに対するrectBの位置を検査
　　　　　　'きれいなコードではないけれど、If文でひとつずつ精査していくこととする。
　　　　　　'Ｂの上がＡの下よりも下にあるかＢの下がＡの上よりも上にあれば重ならない。
　　　　　　If rectB(3) <= rectA(4) Or rectB(4) >= rectA(3) Then
　　　　　　Else
　　　　　　　　If rectB(2) >= rectA(1) Or rectB(1) <= rectA(2) Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("交差します")
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　End If
　　　　　　
　　　　Next j
　　Next i
　　
End Sub
【36740】Re:複数の長方形における干渉をチェック...
発言  ハト  - 06/4/11(火) 17:05 -
引用なし
パスワード
   確かにクイズですね。

ご参考までに

>ハト さん、みなさん。
>こんにちは。
>
>どうも、こういうクイズみたいな構造は苦手です。
>こたつねこさんが回答されてるみたいですが、一応。
>下記のコードでどうでしょう。速度は考慮してませんし、
>合ってるのかわからないから、エラー処理もしてません。
>間違っているような気もして恥ずかしいのですが。
>
>Sub test2()
>
>　　Dim rectA(1 To 4) As Double, rectB(1 To 4) As Double
>　　Dim i As Integer, j As Integer
>　　
>　　For i = 17 To 66
ここは以下の方がいいですね
66行目が最後ですので次の比較対象がありません

　　For i = 17 To 65

>　　
>　　　　'rectA、rectBを四角形とし、それぞれの上下左右の座標値を格納
>　　　　
>　　　　rectA(1) = Range("F" & i) + Range("I" & i) / 2　'右
>　　　　rectA(2) = Range("F" & i) - Range("I" & i) / 2　'左
>　　　　rectA(3) = Range("G" & i) + Range("J" & i) / 2　'上
>　　　　rectA(4) = Range("G" & i) - Range("J" & i) / 2　'下
>　　
>
>　　　　For j = i + 1 To 66
>　　　　　　rectB(1) = Range("F" & j) + Range("I" & i) / 2　'右
>　　　　　　rectB(2) = Range("F" & j) - Range("I" & i) / 2　'左
>　　　　　　rectB(3) = Range("G" & j) + Range("J" & i) / 2　'上
>　　　　　　rectB(4) = Range("G" & j) - Range("J" & i) / 2　'下
>　　　　
>　　　　　　'rectAに対するrectBの位置を検査
>　　　　　　'きれいなコードではないけれど、If文でひとつずつ精査していくこととする。
>　　　　　　'Ｂの上がＡの下よりも下にあるかＢの下がＡの上よりも上にあれば重ならない。
>　　　　　　If rectB(3) <= rectA(4) Or rectB(4) >= rectA(3) Then
比較に＝がありますが、このケースは線が重なります。
線が重なるのはＯＫ？

>　　　　　　Else
>　　　　　　　　If rectB(2) >= rectA(1) Or rectB(1) <= rectA(2) Then
>　　　　　　　　Else
>　　　　　　　　　　MsgBox ("交差します")
>　　　　　　　　　　Exit Sub
このケースだと
　　　Exit Sub
ではありません。プログラムが終了してしまいます
For文の場合は
　　　Exit For
です
もっともこの場合は後続の処理がないので省略可能です

>　　　　　　　　End If
>　　　　　　End If
>　　　　　　
>　　　　Next j
>　　Next i
>　　
>End Sub
【36741】Re:複数の長方形における干渉をチェック...
発言  こたつねこ  - 06/4/11(火) 17:41 -
引用なし
パスワード
   ▼ハト さん：

みなさん、こんにちは

>この比較ですとＢの四角形の中にＡの四角形が内包されるケースがひっかかりま
>せん
>以下の様にしてみたらどうでしょうか？
>　　If rectB(3) < rectA(4) Or rectB(4) > rectA(3) Then
>　　　　f = False
>　　Else
>　　　　f = True
>　　End if
>
余計なお世話かもしれませんが・・・
上記の条件だと、正常に判断できないと思いますよ

例えば
rectA(3)=1,rectA(4)=7
rectB(3)=6,rectB(4)=8
の場合
f=True
にならなければいけないと思うのですが

rectB(3) < rectA(4)は 6<7=True
rectB(4) > rectA(3)は 8>1=True
True Or True=True

なので
f=False
になりませんか？
【36742】Re:複数の長方形における干渉をチェック...
発言  ハト  - 06/4/11(火) 18:06 -
引用なし
パスワード
   ▼こたつねこ さん：
>▼ハト さん：
>
>みなさん、こんにちは
>
>>この比較ですとＢの四角形の中にＡの四角形が内包されるケースがひっかかりま
>>せん
>>以下の様にしてみたらどうでしょうか？
>>　　If rectB(3) < rectA(4) Or rectB(4) > rectA(3) Then
>>　　　　f = False
>>　　Else
>>　　　　f = True
>>　　End if
>>
>余計なお世話かもしれませんが・・・
>上記の条件だと、正常に判断できないと思いますよ
>
>例えば
>rectA(3)=1,rectA(4)=7
>rectB(3)=6,rectB(4)=8
>の場合
>f=True
>にならなければいけないと思うのですが
>
>rectB(3) < rectA(4)は 6<7=True
>rectB(4) > rectA(3)は 8>1=True
>True Or True=True
>
>なので
>f=False
>になりませんか？

確かにそうなんですが、
>rectA(3) = Range("G" & i) + Range("J" & i) / 2　'上
>rectA(4) = Range("G" & i) - Range("J" & i) / 2　'下
ということなんで
rectA(3) ＞ rectA(4)
rectB(3) ＞ rectB(4)
が条件なのでこの判断でいけると思います
【36744】Re:複数の長方形における干渉をチェック...
発言  こたつねこ  - 06/4/11(火) 18:30 -
引用なし
パスワード
   ▼ハト さん：
みなさん。こんにちは

>確かにそうなんですが、
>>rectA(3) = Range("G" & i) + Range("J" & i) / 2　'上
>>rectA(4) = Range("G" & i) - Range("J" & i) / 2　'下
>ということなんで
>rectA(3) ＞ rectA(4)
>rectB(3) ＞ rectB(4)
>が条件なのでこの判断でいけると思います

上下の計算が違いましたか＾＾；
気が付きませんでした、失礼しました。
【36745】Re:複数の長方形における干渉をチェック...
発言  ichinose  - 06/4/11(火) 21:42 -
引用なし
パスワード
   皆さん、こんばんは。

作業列を使用した方法です。
'================================================
Sub main()
　　Const sagyo = 10 'この例ではＯ列を作業列に使っています
　　Dim rng As Range
　　Dim arng As Range
　　Set rng = Range(Cells(17, "e"), Cells(Rows.Count, "e").End(xlUp))
　　rng.Interior.ColorIndex = xlNone
　　If rng.Row >= 17 And rng.Count > 1 Then
　　　 On Error Resume Next
　　　 Names("rec").Delete
　　　 Names.Add "rec", rng
　　　 With rng
　　　　　With .Offset(0, sagyo)
　　　　　　 .Formula = _
　　　　　　　 "=IF(D17=1," & _
　　　　　　　 "if(SUMPRODUCT(" & _
　　　　　　　 "(ABS(OFFSET(rec,0,1)-F17)<=(OFFSET(rec,0,4)+I17)/2)*" & _
　　　　　　　 "(ABS(OFFSET(rec,0,2)-G17)<=(OFFSET(rec,0,5)+J17)/2))>1,1,""""),"""")"
　　　　　　 Err.Clear
　　　　　　 Set arng = .SpecialCells(xlCellTypeFormulas, xlNumbers)
　　　　　　 If Err.Number = 0 Then
　　　　　　　　arng.Cells(1).Offset(0, -sagyo).Interior.ColorIndex = 6
　　　　　　　　End If
　　　　　　 .Formula = ""
　　　　　　 End With
　　　　　End With
　　　 Names("rec").Delete
　　　 End If
End Sub

これとは別に、数式と条件付書式を使用してもちょっと仕様が違いますが、
できそうですよ！！

試してみて下さい。
【36746】Re:複数の長方形における干渉をチェック...
回答  平塚在住  - 06/4/11(火) 22:37 -
引用なし
パスワード
   しとうとさん こんにちは。

すでに、皆さんがいろんな回答を寄せてらっしゃいますが、
干渉のチェックの部分だけ作ってみました。

考え方は
(1) 長方形１＆２の中心を結ぶ線分の角度 ang と距離 dist を計算。
(2) 角度 ang で長方形１の中心を切断する線分の距離 sect1 を
　　計算。
(3) 角度 ang で長方形２の中心を切断する線分の距離 sect2 を
　　計算。
(4) dist - (sect1 + sect2)/2 の正負に基づいて、干渉を判定。


Sub test()

　Dim x1 As Double, y1 As Double, a1 As Double, b1 As Double, _
　　　x2 As Double, y2 As Double, a2 As Double, b2 As Double

　x1 = 0 '長方形１の中心のＸ座標
　y1 = 0 '長方形１の中心のＹ座標
　a1 = 10 '長方形１の横の長さ
　b1 = 5 '長方形１の縦の長さ
　x2 = 11 '長方形２の中心のＸ座標
　y2 = 1 '長方形２の中心のＹ座標
　a2 = 1 '長方形２の横の長さ
　b2 = 1 '長方形２の縦の長さ

　MsgBox InterCheck(x1, y1, a1, b1, x2, y2, a2, b2)

End Sub


Private Function InterCheck(x1 As Double, y1 As Double, a1 As Double, _
　　b1 As Double, x2 As Double, y2 As Double, a2 As Double, _
　　b2 As Double) As Boolean
　　　　
　Dim ang As Double, dist As Double, sect(2) As Double, chd As Double, _
　　　Pi As Double
　Pi = 4 * Atn(1)

　If x1 = x2 Then
　　　　　ang = Pi / 2
　　　Else
　　　　　ang = Abs(Atn((y1 - y2) / (x1 - x2)))
　End If
　dist = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5
　sect(1) = sectLength(ang, a1, b1)
　sect(2) = sectLength(ang, a2, b2)
　chd = dist - (sect(1) + sect(2)) / 2
　If chd <= 0 Then InterCheck = True Else InterCheck = False
　　　　
End Function

　　　　　　
Private Function sectLength(ang As Double, a As Double, b As Double) _
　　As Double

　Dim ath As Double, Pi As Double

　ath = Abs(Atn(b / a))
　If ang < ath Then
　　　　　sectLength = a / Cos(ang)
　　　Else
　　　　　sectLength = b / Sin(ang)
　End If

End Function
【36747】Re:複数の長方形における干渉をチェック...
発言  ハト  - 06/4/12(水) 8:09 -
引用なし
パスワード
   すみません、一部訂正です

>
>>　　　　　　Else
>>　　　　　　　　If rectB(2) >= rectA(1) Or rectB(1) <= rectA(2) Then
>>　　　　　　　　Else
>>　　　　　　　　　　MsgBox ("交差します")
>>　　　　　　　　　　Exit Sub
>このケースだと
>　　　Exit Sub
>ではありません。プログラムが終了してしまいます
>For文の場合は
>　　　Exit For
>です
>もっともこの場合は後続の処理がないので省略可能です
>
>>　　　　　　　　End If

交差が1個でもあれば、それで終了なら
　　　Exit Sub
です

全部チェックするなら
　　　Exit Sub
も
　　　Exit For
もいりません

　　　Exit For
だと　５番目に対して１０番目、１５番目と交差する四角形が複数あっても
１つめの交差（１０番目）を見つけた時点でループを抜けてしまい
６番目に対する交差をチェックしにいってしまいます。

申し訳ありませんでした
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7808 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free