円内の座標を求めること

前提・実現したいこと

・座標を求めれるようにすること。
・座標を求めるプログラムを考えています。

発生している問題・エラーメッセージ

・どうすれば出来るのかが分からない。
エラーメッセージ

試したこと

・

補足情報（FW/ツールのバージョンなど）

y_waiwai

2020/10/23 23:47

いまいち意味不明なんで、図に書いて説明できませんか

meg_

2020/10/24 00:24

タグに「VBA」「Excel」とありますが、無関係ではありませんか？

mattuwan

2020/10/24 01:06 編集

＞大きくなる形でん～ここの意味がわからんです。とりあえず当りをつけて、円に外接する正方形内で割って、各点が円の中に入ってないものは除外すればいいのでは？円の中か外かは、その座標と円の中心とのの距離を求めて半径より大きいか小さいかで判断できますよね？ 2点間の距離は平方根の定理で求められますよね？

行動規範の内容に同意します

回答5件

約１万もの座標を円内に、均等に隙間が無いように配置したい。

円の中に小さな六角形を隙間なく敷き詰め（約１万個）、
それら個々の六角形の中心座標を網羅する。

という数学の命題でしょうか？　

イメージとして「吊り橋のワイヤーケーブルの断面」かな？

それならば、ＶＢＡのプログラミング以前に、

恐らく「そういう数学の一般的な命題」ならば
その解法・アルゴリズム・アプローチ方法が
とっくに確立されていると思えますが如何でしょうか？
（多分、幾何学の参考書に出て来るような・・・）

ネット検索すれば、先ずは数学として「どのように解くか」という
情報が多分見つかると思います。

それを理解してから、その解法をプログラミングするには
どのようにコーディングすれば良いのかというステップに
進むのではないでしょうか？

「解法」自体の調査まで皆に求めているのですか？

既に「解法」をものにしているならば、その「解法」を
数学の素人にも判るような丁寧さで説明すれば良いと思いますよ。

座標を求めるプログラムを考えています
このアルゴリズムをどうすれば出来るのかが分からない

このように書かれている所からすると、
「解法」の調査から のように思えますが・・・

投稿2020/10/24 04:39

AddinBoxTsunoda

総合スコア51

reat326

2020/11/24 01:21 編集

円の中に小さな六角形を隙間なく敷き詰め（約１万個）、という認識で大丈夫です。 (分かりにくい質問なのにここまで汲み取って答えてくださってありがとうございます。。)

AddinBoxTsunoda

2020/10/24 10:50 編集

「平面充填」　「タイル敷き詰め」等のキーワードで根気強く検索してください。もしくは大学の数学教授に教わるとか・・・ある大きさの正方形内に小さな同サイズの六角形を敷き詰めた状態を先に定義してそれら六角形の中心座標を決定し、次にその正方形に内接する円の領域を定め、最後に、その円内に収まる（または円の外＆円周を跨ぐのを除く）六角形を決めれば良いんだろうね。だから、先ずは正方形内での平面充填が出来なければ駄目。『円の内径』イコール『正方形の辺の長さ』ですからね！ Excel , VBA とは関係ない話なので、私はこれにて失礼します。

reat326

2020/11/24 01:21 編集

根気強く検索してみます… 参考になりました！ありがとうございます！

行動規範の内容に同意します

ベストアンサー

一番最初の六角形の中心座標を原点ではなく、(0,Sqr(3)×L)から始めてみました。これだと、第一象限と第三象限で原点がかぶりませんｗ

VBA
1Function f_blnTest2() As Boolean
2    Dim dblL As Double  '六角形の一辺の半分
3    Dim lngA As Long    'x軸方向の係数
4    Dim lngB As Long    'y軸方向の係数の一部
5    Dim lngB0 As Long   'y軸方向の係数の一部の初期値
6    Dim lngRow1 As Long '第一、三象限のセルの行位置
7    Dim lngRow2 As Long '第二、四象限のセルの行位置
8    Dim dblX As Double  '第一象限のx座標
9    Dim dblY As Double  '第一象限のy座標
10    Dim wsh1 As Worksheet
11    
12    Set wsh1 = Worksheets(1)
13    wsh1.Cells(1, 1).CurrentRegion.ClearContents
14    lngRow1 = 1
15    lngRow2 = 1
16    wsh1.Cells(lngRow1, "A").Value = "第一象限x"  'x軸を含む
17    wsh1.Cells(lngRow1, "B").Value = "第一象限y"  'y軸を含む
18    wsh1.Cells(lngRow2, "C").Value = "第二象限x"
19    wsh1.Cells(lngRow2, "D").Value = "第二象限y"
20    wsh1.Cells(lngRow1, "E").Value = "第三象限x"  'x軸を含む
21    wsh1.Cells(lngRow1, "F").Value = "第三象限y"  'y軸を含む
22    wsh1.Cells(lngRow2, "G").Value = "第四象限x"
23    wsh1.Cells(lngRow2, "H").Value = "第四象限y"
24    
25    dblL = Sqr(2) * 3 ^ (1 / 4) * Sqr(Atn(1)) / 6
26    
27    lngB0 = 1
28    Do While lngA * dblL <= 100 / 2
29        lngB = lngB0
30        Do While Sqr((lngA * dblL) ^ 2 + (lngB * Sqr(3) * dblL) ^ 2) <= 100 / 2
31            dblX = lngA * dblL
32            dblY = lngB * Sqr(3) * dblL
33            lngRow1 = lngRow1 + 1
34            Cells(lngRow1, "A").Value = dblX
35            Cells(lngRow1, "B").Value = dblY
36            Cells(lngRow1, "E").Value = -dblX
37            Cells(lngRow1, "F").Value = -dblY
38            If dblX <> 0 And dblY <> 0 Then
39                lngRow2 = lngRow2 + 1
40                Cells(lngRow2, "C").Value = -dblX
41                Cells(lngRow2, "D").Value = dblY
42                Cells(lngRow2, "G").Value = dblX
43                Cells(lngRow2, "H").Value = -dblY
44            End If
45            lngB = lngB + 2
46        Loop
47        lngA = lngA + 3
48        lngB0 = 1 - lngB0
49    Loop
50End Function

座標の数は、10006個になりました。

投稿2020/10/25 20:20

kitasue

総合スコア314

暇だったので図解してみた

六角形の中心座標が決まれば「1：2：√３」の直角三角形から
頂点の座標(x,y)も求まる。

六角形を何個作れば良いかは、中心座標が半径値を超えるまで。
内接円の半径（イコール正方形の辺の半分）をＡとすれば、
概ねＸ/Ｙ軸方向に各「Ａ ÷ ( 2L*√３ ) 」回かな。

中心(0,0)から頂点(x,y)までの距離を求めて、
正方形の内接円の半径（イコール正方形の辺の半分）を
超えていないか判定すれば、円内/外が決まる。

(0,0) , Ｙ軸グループ , Ｘ軸グループ , 第１象限グループが
出来上がれば、各々の座標を符号反転すれば残りが決まる。

投稿2020/10/25 08:27

編集2020/10/26 03:46

AddinBoxTsunoda

総合スコア51

reat326

2020/10/25 13:19

わざわざ図解までして頂いてありがとうございます。。私のような者でも物凄く分かりやすかったです。度々本当にありがとうございます！

kitasue

2020/10/26 12:46

どうもありがとうございました。

行動規範の内容に同意します

内径というのは直径のことですか？
円の中心を原点(0, 0)に、半径を100÷2＝50としてやってみました。

六角形の１辺の長さを2×Lとします。

AddinBoxTsunodaさんの回答を参考に、第一象限（とx軸、y軸上）に六角形を配置していきます。
一つの六角形の中心を原点に配置します。座標は(0, 0)。
そして、その上に六角形を配置します。座標は、(0, 2×Sqr(3)×L)。Sqrというのは平方根のことです。
さらに、その上に六角形を配置します。座標は、(0, 4×Sqr(3)×L)。
：（以下略）

y軸上に六角形を配置したら、次に、そのすぐ右に六角形を配置します。
最初の座標は、(3×L, 1×Sqr(3)×L)、
その上の座標は、(3×L, 3×Sqr(3)×L)、
その上の座標は、(3×L, 5×Sqr(3)×L)、
：（以下略）

さて、fanaさんの回答を参考に、六角形の面積を円の面積の１万分の１とすると、
2×L×Sqr(3)×L÷2＝π×(100÷2)^2÷10000
です。
以上を元にコードを書いてみました。

VBA
1Function f_blnTest1() As Boolean
2    Dim dblL As Double  '六角形の一辺の半分
3    Dim lngA As Long    'x軸方向の係数
4    Dim lngB As Long    'y軸方向の係数の一部
5    Dim lngB0 As Long   'y軸方向の係数の一部の初期値
6    Dim lngRow1 As Long '第一、三象限のセルの行位置
7    Dim lngRow2 As Long '第二、四象限のセルの行位置
8    Dim dblX As Double  '第一象限のx座標
9    Dim dblY As Double  '第一象限のy座標
10    Dim wsh1 As Worksheet
11    
12    Set wsh1 = Worksheets(1)
13    wsh1.Cells(1, 1).CurrentRegion.ClearContents
14    lngRow1 = 1
15    lngRow2 = 1
16    wsh1.Cells(lngRow1, "A").Value = "第一象限x"  'x軸を含む
17    wsh1.Cells(lngRow1, "B").Value = "第一象限y"  'y軸を含む
18    wsh1.Cells(lngRow2, "C").Value = "第二象限x"
19    wsh1.Cells(lngRow2, "D").Value = "第二象限y"
20    wsh1.Cells(lngRow1, "E").Value = "第三象限x"  'x軸を含む
21    wsh1.Cells(lngRow1, "F").Value = "第三象限y"  'y軸を含む
22    wsh1.Cells(lngRow2, "G").Value = "第四象限x"
23    wsh1.Cells(lngRow2, "H").Value = "第四象限y"
24    
25    dblL = Sqr(2) * 3 ^ (1 / 4) * Sqr(Atn(1)) / 6
26    
27    Do While lngA * dblL <= 100 / 2
28        Do While Sqr((lngA * dblL) ^ 2 + (lngB * Sqr(3) * dblL) ^ 2) <= 100 / 2
29            dblX = lngA * dblL
30            dblY = lngB * Sqr(3) * dblL
31            lngRow1 = lngRow1 + 1
32            Cells(lngRow1, "A").Value = dblX
33            Cells(lngRow1, "B").Value = dblY
34            Cells(lngRow1, "E").Value = -dblX
35            Cells(lngRow1, "F").Value = -dblY
36            If dblX <> 0 And dblY <> 0 Then
37                lngRow2 = lngRow2 + 1
38                Cells(lngRow2, "C").Value = -dblX
39                Cells(lngRow2, "D").Value = dblY
40                Cells(lngRow2, "G").Value = dblX
41                Cells(lngRow2, "H").Value = -dblY
42            End If
43            lngB = lngB + 2
44        Loop
45        lngA = lngA + 3
46        lngB0 = 1 - lngB0
47        lngB = lngB0
48    Loop
49End Function