[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『緯度経度を指定してその範囲内のデータを抽出』（初心者）
VBAで出来るのか分からないのですが、ひとつ伺いたいことがあります。
あるフォルダにCSVファイルがいくつかあり、そのフォルダにアクセスして
緯度経度を指定し、その緯度経度の範囲内にあるデータを抽出したいです。
ひとつのファイルから抽出するのではなく、フォルダ内のすべてのファイルから抽出したいです。
ファイルのフォーマットは全て同じです。
（ファイルの例）
A列 B列 C列
1行目 1 133.05 36.78
2行目 2 133.90 35.34
・ ・ ・ ・
・ ・ ・ ・
抽出したい範囲の四点の緯度経度を入力し、
選択した四角の範囲内のデータを抽出してCSVファイルで新たにファイルを作成したいです。。
これってVBAでできるんですか？
初心者で分からず申し訳ございませんが、よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows8 ＞
新たに作成するＣＳＶファイルのレイアウトは？ 各元ファイルの該当の情報を羅列しても、どのファイルにあったかわからなくなってもいいなら 元ファイルのレイアウトのようなものでもいいのでしょうが。
また
>抽出したい範囲の四点の緯度経度を入力し、
どのように指定する予定ですか？
追加。
経度って 東経 とか 西経 があるのでは？ 緯度も 北緯とか南緯とか。 それは無視でいいのでしょうか？
（β） 2017/03/05(日) 22:37
指定する方法ですが、
四点の緯度経度を選んで四角形を作り、
その四角形に入る座標のデータを取り出したいです。
（うまく伝わらずすみません。）
東経や西経とかは無視していただいて結構です。
（初心者） 2017/03/05(日) 22:57
>四点の緯度経度を選んで四角形を作り、
？？？？？
まだ伝わっていません。 シート上に四角形がある？ で、その四角形の緯度経度の範囲は、どうやってわかるんですか？？
ちゃんと、その四角形のあるシートのレイアウトを説明しないと、神様でもわかりませんよ？
（ β） 2017/03/05(日) 23:06
とりあえず、マクロブックの "Sheet1" に以下のような情報が記入されているという前提です。 (四角形云々は、応用問題ですから、ちゃんとした説明があってから、それに合わせます）
|[A] |[B]
[1]|130.2|135.5
[2]| 25| 40
以下の処理では、まとめた新規ブックを作り上げるところまでです。 これを、どのフォルダになんという名前で保存したいのかがわからないので。 この出来上がりのブックをＣＳＶとして保存するコードはマクロ記録をとればわかるはずですので そちらで追加してください。
また、元ＣＳＶファイルがあるフォルダは、デスクトップ上の "対象フォルダ" という名前にしてあります。
シート名やフォルダに関しては ★や●のところを、いかようにも変更してください。
Sub Sample()
Dim fLongi As Double
Dim tLongi As Double
Dim fLati As Double
Dim tLati As Double
Dim fPath As String
Dim fName As String
Dim shF As Worksheet
Dim shT As Worksheet
Dim i As Long
Dim c As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Sheet1") '★
fLongi = .Range("A1").Value
tLongi = .Range("B1").Value
fLati = .Range("A2").Value
tLati = .Range("B2").Value
End With
Set shT = Workbooks.Add.Sheets(1)
fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\対象フォルダ\" '●
fName = Dir(fPath & "*.csv")
Do While fName <> ""
Set shF = Workbooks.Open(fPath & fName).Sheets(1)
For Each c In shF.Range("A1", shF.Range("A" & Rows.Count).End(xlUp))
If c.Offset(, 1).Value >= fLongi And c.Offset(, 1).Value <= tLongi Then
If c.Offset(, 2).Value >= fLati And c.Offset(, 2).Value <= tLati Then
i = i + 1
shT.Cells(i, "A").Resize(, 3).Value = c.Resize(, 3).Value
End If
End If
Next
shF.Parent.Close False
fName = Dir()
Loop
End Sub
（ β） 2017/03/05(日) 23:13
適宜、取り出したい空間の範囲ごとに
緯度経度を入力し、データを抽出するイメージです。
緯度経度の範囲は、場合によって変わります。
四角形がシートにあるのではなく、
入力した緯度経度の四点の範囲内に該当する
座標のデータを取り出すイメージです。
レイアウトはA列に経度、B列に緯度があるような
かたちです。
（初心者） 2017/03/05(日) 23:20
（マナ） 2017/03/05(日) 23:38
マナさんのご指摘、眠いので、明日、頭がすっきりしてから考えます。 (指定範囲が矩形であれば、このままでいいと思うんですが、ひし形とか台形といったイメージなんでしょうかね？）
あっ！ だめだ。明日は早朝から、外出でした。 マナさんフォローいただければありがたいですぅ。
To 初心者さん （このＨＮ あまりよくないですよ）
>適宜、取り出したい空間の範囲ごとに >緯度経度を【入力】し、
>四角形がシートにあるのではなく、 >【入力】した緯度経度の四点の範囲内に該当する
★だから、どこに、どのように【入力】するのかを聞いています。
>レイアウトはA列に経度、B列に緯度があるようなかたちです。
★私が聞いているのは元ＣＳＶファイルや、まとめあげるＣＳＶファイルのレイアウトではなく 経度緯度を【入力】するといわれる、そのシートのレイアウトです。
（ β） 2017/03/05(日) 23:50
（γ） 2017/03/05(日) 23:56
わぁ、γさんにも登場いただき心強いです。 心おきなく、皆さんにおまかせできそうです。
なんとなく、眠気をこらえて、イメージなんですが、４点が 時計回りでも、その逆でもいいのですけど とりあえず時計回り順に指定されていたとして。
個別の座標があって、そこから ある頂点までの線を考えます。で、その時計回りの次の頂点までの線と、その線との角度が 0°以上180°以内、 さらに、そこからの線と、次の時計回りの次の頂点までの線の角度が0°以上180°以内、・・・・
とたどって、元の頂点までずっと0°以上180°以内なら、範囲内。マイナスないしは180°超のものがあわられたら範囲外。
眠いので、まったく抜けているかもしれないイメージですけど。
（β） 2017/03/06(月) 00:17
＞ひとつのファイルから抽出するのではなく、フォルダ内のすべてのファイルから抽出したいです。
とりあえず、欲張ると考えがとっ散らかってわけわかんなくなるので、
一つのファイルで考えてみましょう。
（繰り返すのはプログラムは得意ですので、後からどうにでもなると思います）
そもそも、マクロを作るのは、
「初心者」さんあなた自身です。
それを肝に銘じて取り組んでください。
で、CSVファイルの中身をここにコピペしてみません？
で、それで、どういう値を入れて、マクロを実行したら、
どうなって欲しいかも、合わせて説明してみましょう。
たぶん、２点の座標を指定して、
それで形作られる矩形の中に入る座標を抽出したいのですよね？
４点で、もうちょっと歪な四角が指定されることがあるのだろうか。。。。
（そこまでするなら、多角形で指定したい気が。。。）
（まっつわん） 2017/03/06(月) 09:42
で、長方形の範囲内を判定したいならば、X座標が指定の範囲内か、Y座標が指定の範囲内かを判定。両方共範囲内ならば、四角形の範囲内だと判ります。とても簡単なIf文ですから、ご自身でコーディングしてみてください。
（???） 2017/03/06(月) 09:48
いわゆる長方形、２点の座標だけで決まる領域におさまるかどうかなら、（ β） 2017/03/05(日) 23:13 のコードで ＯＫなんでしょうけど、（初心者） 2017/03/05(日) 23:20 で、それは ＮＧ，あくまで４点の座標を指定すると ダメ押しされましたので・・・
なんとなく、別のアイデアが沸いてきたんですが、コード以前に、そのアイデアが果たして正しいのかどうかを 紙の上で線を引きまくって考え込んでいます・・・・
（β） 2017/03/06(月) 14:37
四点の緯度経度から計算される四角形の面積が、その四点に座標xを加えた五点からなる五角形の面積より大きければ、その座標xは四角形の内部にある。
（mm） 2017/03/06(月) 15:15
>その四点に座標xを加えた五点からなる五角形
なるほどです！
ただ、４点指定が時計回り等、順序正しく指定されていたとして、座標xが範囲内なら たぶん、座標xから任意の頂点->次の頂点->次の頂点->次の頂点->最後の頂点->座標x でも 任意の頂点->次の頂点->三番目の頂点->座標x->最後の頂点 でも 五角形になると思いますが 座標xが範囲外の場合、必ずしも５角形にならず、辺が交わってしまうケースもあると思いますので どういう順番で結びつけると五角形になるのか、そこがポイントなんでしょうか。
このあたりも、数学的な理論で法則があるんでしょうね、きっと。
（β） 2017/03/06(月) 17:42
こんばんわ。
>入力した緯度経度の四点の範囲内に該当する >座標のデータを取り出すイメージです。 この意味が、（mm） 2017/03/06(月) 15:15 なのだとしたら、 基準になるレイアウトはマクロブックの左端のシートに以下のようになってるとして、
A B
1 経度 緯度
2 133.05 36.78
3 133.9 35.34
4 275.85 -205.14
5 276.7 -206.58
多分以下のコードで出来ると思います。
エラー処理などはしてないので、数値以外のデータなどがあればエラーで止まります。 csvファイルのあるフォルダへのフルパスは適切なパスにして下さい。 マクロシートの基準値の入っているシートが左端のシートじゃない時は修正して下さい。
それぞれの座標の値は少数2桁までですか？ 演算誤差の影響を無くす為、全ての値を100倍してますが、3桁とか存在するなら1000倍に増やして下さい。
Sub test()
Const strPath As String = "C:\Users\*****\*****\" 'csvファイルのあるフォルダのフルパス
Dim file_Name As String
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim x(1 To 5) As Double
Dim y(1 To 5) As Double
Dim s1 As Double, s2 As Double, s2a As Double
Dim v As Variant
Dim i As Long
Dim k As Long
Set sh1 = ThisWorkbook.Sheets(1)
'四角形の座標
x(1) = sh1.Range("A2").Value * 100
x(2) = sh1.Range("A3").Value * 100
x(3) = sh1.Range("A4").Value * 100
x(4) = sh1.Range("A5").Value * 100
y(1) = sh1.Range("B2").Value * 100
y(2) = sh1.Range("B3").Value * 100
y(3) = sh1.Range("B4").Value * 100
y(4) = sh1.Range("B5").Value * 100
'四角形の面積と五角形の面積の途中計算
s1 = (x(1) - x(2)) * (y(1) + y(2))
s1 = s1 + (x(2) - x(3)) * (y(2) + y(3))
s1 = s1 + (x(3) - x(4)) * (y(3) + y(4))
s2a = s1
s1 = s1 + (x(4) - x(1)) * (y(4) + y(1))
s1 = Abs(s1 * 10 / 2)
'csvファイルの読込
file_Name = Dir(strPath & "*.csv")
If file_Name = "" Then Exit Sub
Set sh2 = Workbooks.Add.Sheets(1)
Do
Set sh3 = Workbooks.Open(strPath & file_Name).Sheets(1)
v = sh3.Range("A1", sh3.UsedRange).Value
For i = 1 To UBound(v, 1)
'五角形の面積計算と四角形の方が大きかったら転記
s2 = s2a + (x(4) - v(i, 2) * 100) * (y(4) + v(i, 3) * 100)
s2 = s2 + (v(i, 2) * 100 - x(1)) * (v(i, 3) * 100 + y(1))
s2 = Abs(s2 * 10 / 2)
If s1 >= s2 Then
k = k + 1
sh2.Cells(k, "A").Value = v(i, 1)
sh2.Cells(k, "B").Value = v(i, 2)
sh2.Cells(k, "C").Value = v(i, 3)
End If
Next i
'次のファイル
sh3.Parent.Close False
file_Name = Dir()
Loop Until file_Name = ""
End Sub
（sy） 2017/03/06(月) 00:04
To syさん
アップされたコードを流してみました。
用いたテストデータは以下です。
●マクロブック
|[A] |[B]
[1]|経度|緯度
[2]| 130| 40
[3]| 135| 80
[4]| 140| 30
[5]| 138| 20
●CSVファイル その１
|[A]|[B] |[C]
[1]| 1|133.05|36.78
[2]| 2| 133.9|35.34
[3]| 3| 125| 30
[4]| 4| 135| 60
[5]| 5| 131| 60
[6]| 6| 150| 10
●CSVファイル その２
|[A]|[B] |[C]
[1]| 10|133.05|36.78
[2]| 11| 133.9|35.34
[3]| 12| 125| 30
[4]| 13| 135| 60
[5]| 14| 120| 50
●結果
|[A]|[B] |[C]
[1]| 1|133.05|36.78
[2]| 2| 133.9|35.34
[3]| 4| 135| 60
[4]| 5| 131| 60
[5]| 6| 150| 10
[6]| 10|133.05|36.78
[7]| 11| 133.9|35.34
[8]| 13| 135| 60
各データ、それぞれいいかげんですので、領域内、領域外 それぞれ、どうだというところまでは検証していませんが 少なくとも 指定の領域は 緯度でいえば 20〜80 ですので 結果の中の 緯度が 10 のものは、領域外のはずですよね。
（β） 2017/03/07(火) 00:39
βさん
ありがとうございます。
ちょっと勘違いもあって、データによっては頂点のプロット順が変わる事を想定していませんでした。
150,10のデータの時は1,2,3,5,4の順番にしないといけないのに、そのまま1,2,3,4,5の順番で計算していた為 凹頂点と辺の重なりが出来てしまい面積が小さくなってしまいました。
すいません。 (sy） 2017/03/06(月) 00:04 は無視して下さい。 今から仕事なので、今日一日暇な時間にプロット順の事をどうするか考えてみます。 先にβさんや他の人からアップされてて意味なくなってるかも知れませんが、 不完全なままは情けないので、帰ったらアップさせて頂きます。
（sy） 2017/03/07(火) 07:20
ご自身でも作れるように、取り敢えず考え方だけ提示します。
三角形は2通りしか無いのでプロット順が123、132どちらでも同じになります。
四角形は時計回り、反時計回りの外周を結ぶ2通りが必ず最大面積になるので、 6通りしか無いので総当たりで最大面積になる時のプロット順を用います。
五角形のプロット順はXY座標で直線距離を求め、一番近い2点の頂点の間にすれば 辺の重なりの無い正確な面積を求められます。
でも口で言うのは簡単ですけど、ロジック的には結構めんどくさいですね。
（sy） 2017/03/07(火) 08:13
>ちょっと勘違いもあって、データによっては頂点のプロット順が変わる事を想定していませんでした。
そうなんですよね。私も、コメントしましたが、紙の上で ５角形をつくっていくときに、領域外の座標からの場合 線の結び方によって 辺が交わってしまうケースがある、ここを、どうすべきか、何かきっと数学的な理論があるんだろうなと。 でも、数学音痴のβですので、皆目見当がつきません。
> 五角形のプロット順はXY座標で直線距離を求め、一番近い2点の頂点の間にすれば > 辺の重なりの無い正確な面積を求められます。
なるほどなぁと敬服です。
>ロジック的には結構めんどくさいですね
そんな感じですね。 なので、
>先にβさんや他の人からアップされてて意味なくなってるかも知れませんが
少なくとも、私は、syさんの回答を楽しみに、待っています。
（β） 2017/03/07(火) 09:03
考えるだけなら一瞬ですが、コーディングは時間がかかるので、とりあえずパス…。実は長方形で十分でした、とか言われたら脱力ですし。
（???） 2017/03/07(火) 11:14
コードを考える前に問題がありました。
（sy） 2017/03/07(火) 08:13で基本的な考え方を提示しましたが、2つ例外があります。 凹頂点を持つ四角形の場合(形的にはブーメランや三日月型とでも言った方が良いかも)
一つは今回の要件では問題にならない例外ですけど、凹頂点と対角の位置にプロットされた5つ目の座標は、 対角線は辺より長いので四角形の連続するプロットを飛ばしてしまう可能性があります。 例を上げると、1,2,3,4のプロットで2,3,4点の3が凹頂点の時、5からの最短距離が2,3や3,4ではなく、2,4になる時があります。 でも今回の要件では、2,4になる時は必ず面範囲から外れるので、この例外は問題になりません。
もう一つは問題になります。 1,2,3,4のプロットの時が、四角形としては最大面積になる場合で、2,3,4点の3が凹頂点になる時、 2,3,4の三角形の面範囲に5点目が存在する時は計算上外れてしまいます。 但し1,3,2,4や1,2,4,3などのプロットでも四角形は問題なく形成されるので(最大面積では無いと言うだけ) 5点目は範囲内と言う事になります。 この例外を範囲内外どちらにするかは質問者さんにしか決める事は出来ません。(回答者が勝手に判断できません。)
凹頂点は存在しない、全ての頂点は凸頂点だと言うなら、上記の例外は発生しません。
1、四角形の条件で凹頂点が存在するような条件設定があるのか？ 2、凹頂点のある時、最大面積範囲からは外れるが、他の面範囲では範囲内になる時に、範囲内外どちらにするか？
上記質問に返答下さい。
（sy） 2017/03/07(火) 20:43
取り敢えず四角形条件には、凸頂点のみしかない場合のtest2と、 四角形条件に凹頂点ありで、何れかの四角形の中に入っていればOKのtest3 をアップします。 凹頂点ありで、最大面積範囲だけOKにするコードは非常に複雑になるので、 返答をお聞きしてから必要であれば書きます。
test2、test3ともD・E列を作業列に使っているので、元々データなどが入っていて、 作業列に使ってはまずい場合は数式挿入先と参照の部分のセル番地を変更して下さい。
Sub test2()
'凹頂点は存在しない
Const strPath As String = "C:\Users\*****\*****\" 'csvファイルのあるフォルダのフルパス
Dim file_Name As String
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim vOrder As String
Dim xy(1 To 4) As Double
Dim x(1 To 6) As Double
Dim y(1 To 6) As Double
Dim v1 As Variant
Dim v2 As Variant
Dim s1 As Double
Dim s2 As Double
Dim i As Long
Dim k As Long
Dim m As Integer
Set sh1 = ThisWorkbook.Sheets(1)
'作業列で四角形面積を計算
sh1.Range("D2:D6").Value = WorksheetFunction.Transpose(Array(1234, 1243, 1423, "順", "最大値"))
sh1.Range("E2").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A4*100)*(B3*100+B4*100),(A4*100-A5*100)*(B4*100+B5*100),(A5*100-A2*100)*(B5*100+B2*100))*10/2)"
sh1.Range("E3").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A5*100)*(B3*100+B5*100),(A5*100-A4*100)*(B5*100+B4*100),(A4*100-A2*100)*(B4*100+B2*100))*10/2)"
sh1.Range("E4").Formula = "=ABS(SUM((A2*100-A5*100)*(B2*100+B5*100),(A5*100-A3*100)*(B5*100+B3*100),(A3*100-A4*100)*(B3*100+B4*100),(A4*100-A2*100)*(B4*100+B2*100))*10/2)"
sh1.Range("E5").Formula = "=INDEX(D2:D4,MATCH(MAX(E2:E4),E2:E4,0))"
sh1.Range("E6").Formula = "=MAX(E2:E4)"
vOrder = sh1.Range("E5").Value
v1 = sh1.Range("A2:B5").Value
s1 = sh1.Range("E6").Value
'csvファイルの読込
file_Name = Dir(strPath & "*.csv")
If file_Name = "" Then Exit Sub
Set sh2 = Workbooks.Add.Sheets(1)
Do
Set sh3 = Workbooks.Open(strPath & file_Name).Sheets(1)
v2 = sh3.Range("A1", sh3.UsedRange).Value
For i = 1 To UBound(v2, 1)
'5点目が四角形範囲内にあるか判定
x(1) = v1(Mid(vOrder, 1, 1), 1)
y(1) = v1(Mid(vOrder, 1, 1), 2)
x(6) = v1(Mid(vOrder, 1, 1), 1)
y(6) = v1(Mid(vOrder, 1, 1), 2)
xy(1) = ((v2(i, 2) - v1(Mid(vOrder, 1, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 1, 1), 2)) ^ 2) ^ 0.5
xy(2) = ((v2(i, 2) - v1(Mid(vOrder, 2, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 2, 1), 2)) ^ 2) ^ 0.5
xy(3) = ((v2(i, 2) - v1(Mid(vOrder, 3, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 3, 1), 2)) ^ 2) ^ 0.5
xy(4) = ((v2(i, 2) - v1(Mid(vOrder, 4, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 4, 1), 2)) ^ 2) ^ 0.5
If xy(1) < xy(3) Then
If xy(2) < xy(4) Then
x(2) = v2(i, 2)
x(3) = v1(Mid(vOrder, 2, 1), 1)
x(4) = v1(Mid(vOrder, 3, 1), 1)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v2(i, 3)
y(3) = v1(Mid(vOrder, 2, 1), 2)
y(4) = v1(Mid(vOrder, 3, 1), 2)
y(5) = v1(Mid(vOrder, 4, 1), 2)
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v1(Mid(vOrder, 3, 1), 1)
x(4) = v1(Mid(vOrder, 4, 1), 1)
x(5) = v2(i, 2)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v1(Mid(vOrder, 3, 1), 2)
y(4) = v1(Mid(vOrder, 4, 1), 2)
y(5) = v2(i, 3)
End If
Else
If xy(2) < xy(4) Then
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v2(i, 2)
x(4) = v1(Mid(vOrder, 3, 1), 1)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v2(i, 3)
y(4) = v1(Mid(vOrder, 3, 1), 2)
y(5) = v1(Mid(vOrder, 4, 1), 2)
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v1(Mid(vOrder, 3, 1), 1)
x(4) = v2(i, 2)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v1(Mid(vOrder, 3, 1), 2)
y(4) = v2(i, 3)
y(5) = v1(Mid(vOrder, 4, 1), 2)
End If
End If
s2 = 0
For m = 1 To 5
s2 = s2 + (x(m) * 100 - x(m + 1) * 100) * (y(m) * 100 + y(m + 1) * 100)
Next m
s2 = Abs(s2 * 10 / 2)
If s1 >= s2 Then
k = k + 1
sh2.Cells(k, "A").Value = v2(i, 1)
sh2.Cells(k, "B").Value = v2(i, 2)
sh2.Cells(k, "C").Value = v2(i, 3)
End If
Next i
'次のファイル
sh3.Parent.Close False
file_Name = Dir()
Loop Until file_Name = ""
sh1.Range("D2:E6").ClearContents
End Sub
Sub test3()
'凹頂点がある、最大面積以外の時でも範囲に含める
Const strPath As String = "C:\Users\*****\*****\" 'csvファイルのあるフォルダのフルパス
Dim file_Name As String
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim vOrder As String
Dim xy(1 To 4) As Double
Dim x(1 To 6) As Double
Dim y(1 To 6) As Double
Dim v1 As Variant
Dim v2 As Variant
Dim s1 As Double
Dim s2 As Double
Dim i As Long
Dim k As Long
Dim m As Integer
Set sh1 = ThisWorkbook.Sheets(1)
'作業列で三角形面積、四角形面積、凹頂点の有無を計算
sh1.Range("D2:D11").Value = WorksheetFunction.Transpose(Array(1234, 1243, 1423, 123, 124, 134, 234, "凹", "順", "最大値"))
sh1.Range("E2").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A4*100)*(B3*100+B4*100),(A4*100-A5*100)*(B4*100+B5*100),(A5*100-A2*100)*(B5*100+B2*100))*10/2)"
sh1.Range("E3").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A5*100)*(B3*100+B5*100),(A5*100-A4*100)*(B5*100+B4*100),(A4*100-A2*100)*(B4*100+B2*100))*10/2)"
sh1.Range("E4").Formula = "=ABS(SUM((A2*100-A5*100)*(B2*100+B5*100),(A5*100-A3*100)*(B5*100+B3*100),(A3*100-A4*100)*(B3*100+B4*100),(A4*100-A2*100)*(B4*100+B2*100))*10/2)"
sh1.Range("E5").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A4*100)*(B3*100+B4*100),(A4*100-A2*100)*(B4*100+B2*100))*10/2)"
sh1.Range("E6").Formula = "=ABS(SUM((A2*100-A3*100)*(B2*100+B3*100),(A3*100-A5*100)*(B3*100+B5*100),(A5*100-A2*100)*(B5*100+B2*100))*10/2)"
sh1.Range("E7").Formula = "=ABS(SUM((A2*100-A4*100)*(B2*100+B4*100),(A4*100-A5*100)*(B4*100+B5*100),(A5*100-A2*100)*(B5*100+B2*100))*10/2)"
sh1.Range("E8").Formula = "=ABS(SUM((A3*100-A4*100)*(B3*100+B4*100),(A4*100-A5*100)*(B4*100+B5*100),(A5*100-A3*100)*(B5*100+B3*100))*10/2)"
sh1.Range("E9").Formula = "=MAX(E5:E8)>MAX(E2:E4)"
sh1.Range("E10").Formula = "=IF(E9,INDEX(D5:D8,MATCH(MAX(E5:E8),E5:E8,0)),INDEX(D2:D4,MATCH(MAX(E2:E4),E2:E4,0)))"
sh1.Range("E11").Formula = "=IF(E9,MAX(E5:E8),MAX(E2:E4))"
vOrder = sh1.Range("E10").Value
v1 = sh1.Range("A2:B5").Value
s1 = sh1.Range("E11").Value
'csvファイルの読込
file_Name = Dir(strPath & "*.csv")
If file_Name = "" Then Exit Sub
Set sh2 = Workbooks.Add.Sheets(1)
Do
Set sh3 = Workbooks.Open(strPath & file_Name).Sheets(1)
v2 = sh3.Range("A1", sh3.UsedRange).Value
For i = 1 To UBound(v2, 1)
'5点目が四角形範囲内にあるか判定
x(1) = v1(Mid(vOrder, 1, 1), 1)
y(1) = v1(Mid(vOrder, 1, 1), 2)
If sh1.Range("E9").Value Then
'凹頂点有
xy(1) = ((v2(i, 2) - v1(Mid(vOrder, 1, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 1, 1), 2)) ^ 2) ^ 0.5
xy(2) = ((v2(i, 2) - v1(Mid(vOrder, 2, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 2, 1), 2)) ^ 2) ^ 0.5
xy(3) = ((v2(i, 2) - v1(Mid(vOrder, 3, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 3, 1), 2)) ^ 2) ^ 0.5
x(5) = v1(Mid(vOrder, 1, 1), 1)
y(5) = v1(Mid(vOrder, 1, 1), 2)
If xy(1) <= xy(2) Then
If xy(2) <= xy(3) Then
x(2) = v2(i, 2)
x(3) = v1(Mid(vOrder, 2, 1), 1)
x(4) = v1(Mid(vOrder, 3, 1), 1)
y(2) = v2(i, 3)
y(3) = v1(Mid(vOrder, 2, 1), 2)
y(4) = v1(Mid(vOrder, 3, 1), 2)
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v1(Mid(vOrder, 3, 1), 1)
x(4) = v2(i, 2)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v1(Mid(vOrder, 3, 1), 2)
y(4) = v2(i, 3)
End If
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v2(i, 2)
x(4) = v1(Mid(vOrder, 3, 1), 1)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v2(i, 3)
y(4) = v1(Mid(vOrder, 3, 1), 2)
End If
s2 = 0
For m = 1 To 4
s2 = s2 + (x(m) * 100 - x(m + 1) * 100) * (y(m) * 100 + y(m + 1) * 100)
Next m
s2 = Abs(s2 * 10 / 2)
Else
'凹頂点無
xy(1) = ((v2(i, 2) - v1(Mid(vOrder, 1, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 1, 1), 2)) ^ 2) ^ 0.5
xy(2) = ((v2(i, 2) - v1(Mid(vOrder, 2, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 2, 1), 2)) ^ 2) ^ 0.5
xy(3) = ((v2(i, 2) - v1(Mid(vOrder, 3, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 3, 1), 2)) ^ 2) ^ 0.5
xy(4) = ((v2(i, 2) - v1(Mid(vOrder, 4, 1), 1)) ^ 2 + (v2(i, 3) - v1(Mid(vOrder, 4, 1), 2)) ^ 2) ^ 0.5
x(6) = v1(Mid(vOrder, 1, 1), 1)
y(6) = v1(Mid(vOrder, 1, 1), 2)
If xy(1) < xy(3) Then
If xy(2) < xy(4) Then
x(2) = v2(i, 2)
x(3) = v1(Mid(vOrder, 2, 1), 1)
x(4) = v1(Mid(vOrder, 3, 1), 1)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v2(i, 3)
y(3) = v1(Mid(vOrder, 2, 1), 2)
y(4) = v1(Mid(vOrder, 3, 1), 2)
y(5) = v1(Mid(vOrder, 4, 1), 2)
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v1(Mid(vOrder, 3, 1), 1)
x(4) = v1(Mid(vOrder, 4, 1), 1)
x(5) = v2(i, 2)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v1(Mid(vOrder, 3, 1), 2)
y(4) = v1(Mid(vOrder, 4, 1), 2)
y(5) = v2(i, 3)
End If
Else
If xy(2) < xy(4) Then
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v2(i, 2)
x(4) = v1(Mid(vOrder, 3, 1), 1)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v2(i, 3)
y(4) = v1(Mid(vOrder, 3, 1), 2)
y(5) = v1(Mid(vOrder, 4, 1), 2)
Else
x(2) = v1(Mid(vOrder, 2, 1), 1)
x(3) = v1(Mid(vOrder, 3, 1), 1)
x(4) = v2(i, 2)
x(5) = v1(Mid(vOrder, 4, 1), 1)
y(2) = v1(Mid(vOrder, 2, 1), 2)
y(3) = v1(Mid(vOrder, 3, 1), 2)
y(4) = v2(i, 3)
y(5) = v1(Mid(vOrder, 4, 1), 2)
End If
End If
s2 = 0
For m = 1 To 5
s2 = s2 + (x(m) * 100 - x(m + 1) * 100) * (y(m) * 100 + y(m + 1) * 100)
Next m
s2 = Abs(s2 * 10 / 2)
End If
If s1 >= s2 Then
k = k + 1
sh2.Cells(k, "A").Value = v2(i, 1)
sh2.Cells(k, "B").Value = v2(i, 2)
sh2.Cells(k, "C").Value = v2(i, 3)
End If
Next i
'次のファイル
sh3.Parent.Close False
file_Name = Dir()
Loop Until file_Name = ""
sh1.Range("D2:E11").ClearContents
End Sub
（sy） 2017/03/08(水) 00:41
＞凹頂点ありで、最大面積範囲
この「最大」面積範囲と言う意味が呑み込めないのですが、 どういう意味なんでしょうか？
私は、4点を結ぶ順序は指定されると思っているのですが、 回答側で適宜アレンジする、と言う考え方なんでしょうか？
例えば、以下４つの座標(■）が与えられた場合 結んでいく順序が決まっていないと四角形は数通りになるので、内部判定は全然違ってきちゃいます。
行 _A_ _B_ _C_ _D_ E │ │ 1 ■ │ A │ A 2 │ │ 3 │ │ 4 │ │ 5 ■ ■ │ B D │ C D 6 │ │ 7 │ │ 8 ■ │ C │ B
もしかして、最大とは△ＡＢＤの大三角形のことですか？
（半平太） 2017/03/08(水) 11:14
半平太さん
>この「最大」面積範囲と言う意味が呑み込めないのですが、 >どういう意味なんでしょうか？ >結んでいく順序が決まっていないと四角形は数通りになるので、内部判定は全然違ってきちゃいます。
四角形を形作る4つの座標のプロット順の組み合わせで、面積の違う四角形が最大3通り出来るんですけど、 その内の面積が最大になるプロット順の四角形の事を指しています。
>もしかして、最大とは△ＡＢＤの大三角形のことですか？ これはtest3の結果は大三角形に含まれるかで判断しています。 test3は3通りの四角形のどれかの面範囲内に収まると言う判別基準です。
>4点を結ぶ順序は指定されると思っているのですが、 ありがとうございます。 間抜けな事に、今回言われて初めて気づきました。 初め全て凸頂点のみの場合の四角形だけを想像して、その場合1通りしか四角形の出来る組み合わせは無いので (時計回り、反時計回りの順番はありますが、面積としては1通り) 順序を指定する余地は無いので、その考えのまま凹頂点の時も同じように考えてしまいました。 普通に考えたら半平太さんの言われるように、凹頂点の時は予めユーザーから指定される事が多いと思います。
質問者さん
(sy） 2017/03/07(火) 20:43の最後で質問している内容に加え、 質問文の中にはプロット順の事までは書かれていませんが、もし凹頂点を含む四角形を指定する場合があるなら、 プロット順は指定になるのでしょうか？ 若しくは、2のように最大面積の四角形 か 全ての四角形(大三角形、test3が返す結果)になるのでしょうか？
順序指定や1つの四角形のみのコードは条件判断の記述がtest3より更に増えるので、まずは返事をお聞かせ下さい。
（sy） 2017/03/08(水) 19:46
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.