Results of 1 - 1 of about 37633 for IF (0.007 sec.)
- [[20140805153308]]
- #score: 1592
- @digest: 62b2c60255a116670fd653c3bfa81a8b
- @id: 65804
- @mdate: 2014-09-01T04:54:45Z
- @size: 44845
- @type: text/plain
- #keywords: tsht (643392), 征服 (393559), 服国 (289292), 口国 (206663), 国id (204301), 未征 (202454), 標登 (123983), 国da (119950), 東経 (113201), 記所 (109000), 北緯 (101028), 国東 (98040), 窓口 (95046), 国王 (94731), 国北 (88868), osht (84347), imx (82972), 邪馬 (80563), s4dr2s (78759), s4dr1s (78759), 馬台 (75979), 登記 (75862), 国々 (74431), 台国 (73934), 国域 (69558), 豪族 (66769), s4ip (64439), 同国 (64439), 城国 (63503), s4jp (63503), s4dr2 (62602), s4dr1 (62602)
- 『エクセルシートで面積を求めたい。』（ひらみの）
エクセルシートを地図に見立て、面積を割り出したいと思います。 1セルは高さ幅とも1kmとします。（つまり1セルは1㎢） 面積を求める際、空白でないセル（文字列や数値）を数えるのは簡単ですが、条件として、空白でないセルが離れている場合、セルを縦方向か横方向のみ繋げるイメージで、面積計算に入れたいと思います。 その計算式やマクロが組めないか教えて頂けないでしょうか?（なお、当方マクロについては、初心者です。） 図において、1〜3のみの面積は3㎢ですが、1〜6の全ての面積は4つのnの部分も合わせ、10㎢と割り出したい。(nはもともと空白部分で、繋げる順番は番号順でなく面積が最も小さくなるように） 利用目的は、1日の配送先約20件〜30件より、概算の配送エリアを調べたく思い、今、住所から緯度経度を割り出し、ピポットテーブル（縦列が北緯、横列が東経）で地図に見立てたシート上のテーブルにプロットされました。 それを繋げ面積を求めたいと思います。 A B C D E F 1行 1 2行 3 2 n 4 n n 3行 6 n 4行 5 ＜ 使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- よくわかりませんが =COUNT("A:E")+COUNTIF("A:E","n") & "km"ですか? （Hara） 2014/08/05(火) 16:59 ---- 回答ありがとうございます。nは空白です。セルを縦または横方向に延ばして、すべての数字を繋げるイメージです。図の数字を延ばしたイメージをnで表現しました。マクロでnを自動的に表現できればと思います。 （ひらみの） 2014/08/05(火) 17:17 ---- ルートが複数あると思いますが? （Hara） 2014/08/06(水) 09:27 ---- ありがとうございます。 nのプロットは最少になるように求めたい。 最少でも複数のパターンが存在する場合は、そのパターンも知りたいのですが、まずは最少のnの数がわかればと思います。 マクロを組むイメージとしては数値1〜6を地形図の山頂と見立て、山頂を一斉に1段ずつ標高上げる。 その際、上下左右に1セル分の道を作る。山頂からのルートが上下左右とも行き止まりの場合は、さらに1段上げ、ルートを広げる。 そして全てのセル（山頂）がつながった時点で、行き止まりのコースは消去する。 残ったコースが複数パターンある場合は、任意の1つのみ残す。 任意の山頂から全ての山を回るに当たり、できるだけ切り開く道を少なくする。 余計イメージがわかりにくいでしょうか? エクセルというより、ゲームソフトの開発のようになってしまいました。 （ひらみの） 2014/08/06(水) 10:12 ---- その説明だとD3:F3がnになると思うのですが・・・ 「任意」ということは「人の手」ってことなら最初から手でやったほうがよっぽど早いような。 （稲葉） 2014/08/06(水) 13:11 ---- ご指摘ありがとうございます。確かにD3:F3がnですね。nの数は図も同じですので、単純に図を書いてしまいました。任意とは、何かしら機械的に優先順位をつける意味として表現しました。（つまり、任意ではないですが、どれをとってといった意味合いです。） 1回のみのマーキングであれば、もちろん手で処理したほうが早いのですが、確認したいデータが多いことと手前まではピポットテーブルで自動化できたので、なんとかできないかと悩んでおります。 （ひらみの） 2014/08/07(木) 10:53 ---- これってnをつけるのが大変に難しいようです。 A B C D E F 1行 1 2行 3 2 n 4 n n 3行 6 n 4行 5 の例示は A B C D E F 1行 1 2行 3 2 n 4 3行 6 n n n 4行 5 としてもできます。面積はどちらも10ですが、 それを求めるロジックが、超難しそう(*_*) （パオ〜〜ン） 2014/08/07(木) 16:36 ---- 図解ありがとうございます。有料でもマクロ組める方を探したいのですが。 （ひらみの） 2014/08/08(金) 09:08 ---- http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13132973758 （マルチーズ） 2014/08/08(金) 10:42 ---- あちらでもコメントでも触れられていますが、最適解はNP完全問題の「頂点被覆問題」に類似でしょうか。 http://ja.wikipedia.org/wiki/%E9%A0%82%E7%82%B9%E8%A2%AB%E8%A6%86%E5%95%8F%E9%A1%8C ちょっと EXCEL でマクロが組めるから、といって簡単に回答できるレベルの問題ではない気がします。 近似解であれば、少しは回答も出やすいと思いますが。 茶々だけですみません。 （Mook） 2014/08/09(土) 02:07 ---- 近似解案です <m(__)m> ※もともと、それ程厳密な話ではないであろうと高をくくっています。 山頂も1キロなら、道路も1キロなどと云う考え方自体がラフですから。 ＞ 最少でも複数のパターンが存在する場合は、そのパターンも知りたいのですが、 これは多分無理です。 単純に左上から右下に20個の山頂が綺麗に並んでいたとしたら、 その正解パターン数は50万通りになっちゃいます。 以下、一つの山頂に邪馬台国のヒミコがいたとして、 周りの山頂にいる豪族達を征服する、と云う設定で考えてみました。 10回程トライして、一番面積の少ないものを解として扱う案です。 コードの一番上に書かれている「データ範囲」と「トライ回数」を決めてから 「Main」を実行してみてください。 (なお、数字が入っていないセルは、未入力セルであるものとします。） <サンプル> ---> ┃ <結果図> 47平方キロと出ました。 ABCDEFGHIJKLMNOP ┃ ABCDEFGHIJKLMNOP 1 1 ┃ 1 1 32 4 5 3 ┃ 32n4 5n3 6 1 8 3 ┃ 6 1 8 3 5 32 4 ┃ n 5n32n4nnn 21 8 6 5 ┃ 21 n8 6n 5 ┃ n n n 32 4 9 ┃ 32n4 9 6 1 ┃ 6 1nn 32 4 ┃ 32n4 6 ┃ 6 貼り付けるコード(標準モジュール用とクラスモジュール用があります） ※貼り付けに先立って、クラスモジュールを1枚挿入して、 表示→プロパティウィンドウ からオブジェクト名を「Class1」→「城国」へ変更してください。 '＜標準モジュールに貼り付けるコード＞-------------------------------------------- 'Option Explicit Const rngToWatch As String = "A1:P10" '←実際の範囲に合わせてください Const トライ回数 As Long = 10 '←10回くらいで十分と思われます Dim WSF As WorksheetFunction Sub main() Dim rngToProc As Range Dim TrialNo As Long Dim resultMap As Variant Dim bestResultSofar As Long Dim thisTimeResult As Long Set rngToProc = Range(rngToWatch) bestResultSofar = rngToProc.Rows.Count * rngToProc.Columns.Count Application.ScreenUpdating = False For TrialNo = 1 To トライ回数 thisTimeResult = 邪馬台国の征服(rngToProc) If thisTimeResult < bestResultSofar Then bestResultSofar = thisTimeResult resultMap = rngToProc.Value End If Next TrialNo rngToProc.Value = resultMap Application.ScreenUpdating = True MsgBox bestResultSofar End Sub Private Function 邪馬台国の征服(ByRef rngToProc) As Long Dim cel As Range, NN As Long Dim 国ID As Long '連番管理 Dim 未征服国の座標登記所 As Object '座標をkeyにして、未征服国のIDを管理 Dim 国々() As New 城国 Dim 邪馬台国 As 城国 Dim 個別国 As Variant Dim 征服候補国DATA As Variant Dim 征服国DATA As Variant Dim 征服国北緯 As Long Dim 征服国東経 As Long Dim 窓口国ID As String Dim 窓口国北緯 As Long Dim 窓口国東経 As Long Dim 新道路 As 城国 Dim 新row As Long Dim 新col As Long Dim 未征服国との距離 As Long Randomize Set WSF = WorksheetFunction Call n削除 '既存のnを除去する Call 縦列駐車パターン先処理 '縦列駐車パターン先処理 Rem ゲーム範囲内の全豪族を登録して、城国を決定する(縦列駐車パターン道路も含む) Set 未征服国の座標登記所 = CreateObject("Scripting.Dictionary") '未征服城国を管理 国ID = 0 For Each cel In rngToProc If Len(cel.Value) > 0 Then 国ID = 国ID + 1 未征服国の座標登記所.Add Join(Array(cel.row, cel.Column)), 国ID ReDim Preserve 国々(1 To 国ID) Call 国々(国ID).setInitialInfo(国ID, cel.row, cel.Column, cel.Value) End If Next Rem 筆頭城国(国ID=1)を邪馬台国と定め隣接する国を征服させる Set 邪馬台国 = 国々(1) 邪馬台国.国王 = "ヒミコ" '国王がヒミコの城国は征服済み 未征服国の座標登記所.Remove 邪馬台国.座標Key '未征服リストから除外 Call 邪馬台国.隣接国征服(未征服国の座標登記所, 国々()) '隣接国を征服する 'Rem 邪馬台国の最近傍国域を調べて道路域を拡張する Do While 未征服国の座標登記所.Count > 0 未征服国との距離 = 0 For Each 個別国 In 国々 If 個別国.国王 = "ヒミコ" Then 征服候補国DATA = 個別国.最近傍国DATA(未征服国の座標登記所) If 未征服国との距離 = 0 Or _ CLng(Split(征服候補国DATA, "#")(0)) < 未征服国との距離 Then 未征服国との距離 = CLng(Split(征服候補国DATA, "#")(0)) 征服国DATA = 征服候補国DATA 窓口国ID = 個別国.国ID ElseIf CLng(Split(征服候補国DATA, "#")(0)) = 未征服国との距離 Then '右優先 窓口国東経 = CLng(Split(国々(窓口国ID).座標Key)(1)) If 窓口国東経 < CLng(Split(個別国.座標Key)(1)) Then 征服国DATA = 征服候補国DATA 窓口国ID = 個別国.国ID End If End If End If Next '進軍路の方向を決定 征服国北緯 = Split(Split(征服国DATA, "#")(1))(0) 征服国東経 = Split(Split(征服国DATA, "#")(1))(1) 窓口国北緯 = Split(国々(窓口国ID).座標Key)(0) 窓口国東経 = Split(国々(窓口国ID).座標Key)(1) Select Case Abs(征服国東経 - 窓口国東経) - Abs(征服国北緯 - 窓口国北緯) Case Is < 0 '南北が遠い 新row = 窓口国北緯 + IIf(窓口国北緯 < 征服国北緯, 1, -1) 新col = 窓口国東経 Case Is > 0 '東西が遠い 新col = 窓口国東経 + IIf(窓口国東経 < 征服国東経, 1, -1) 新row = 窓口国北緯 Case 0 If Application.IsOdd(Rnd() * 10) Then 新row = 窓口国北緯 + IIf(窓口国北緯 < 征服国北緯, 1, -1) 新col = 窓口国東経 Else 新col = 窓口国東経 + IIf(窓口国東経 < 征服国東経, 1, -1) 新row = 窓口国北緯 End If End Select ReDim Preserve 国々(1 To UBound(国々) + 1) Set 新道路 = 国々(UBound(国々)) Call 新道路.setInitialInfo(UBound(国々), 新row, 新col, "n") 未征服国の座標登記所.Add Join(Array(新row, 新col)), 新道路.国ID Call 国々(窓口国ID).隣接国征服(未征服国の座標登記所, 国々()) '窓口国に進軍させる Cells(新row, 新col).Value = "n" '進軍路に「n」を立てる Loop 邪馬台国の征服 = UBound(国々) End Function Sub n削除() '処理する前に前回の「n」を除去する Dim cel As Range For Each cel In Range(rngToWatch) If cel.Value = "n" Then cel.Value = Empty End If Next End Sub Sub 縦列駐車パターン先処理() '間違え易い4パターンを先に「n」で埋める Dim RR, CC, NN Dim cel As Range Dim patern, paternRange, paternDegits, posToFilWithN Dim WSF As WorksheetFunction Set WSF = WorksheetFunction paternRange = Split("A1:C2,A1:C2,A1:B3,A1:B3", ",") paternDegits = Split("101010,010101,100110,011001", ",") posToFilWithN = Split("B1,B2,A2,B2", ",") ' Dim test Dim rngToProc As Range Set rngToProc = Range(rngToWatch) For NN = 1 To 4 'パターン For RR = 1 To rngToProc.Rows.Count - IIf(NN < 3, 1, 2) For CC = 1 To rngToProc.Columns.Count - IIf(NN < 3, 2, 1) patern = "" For Each cel In rngToProc.Offset(RR - 1, CC - 1).Range(paternRange(NN - 1)) patern = patern & IIf(WSF.CountBlank(cel), 0, 1) Next If patern = paternDegits(NN - 1) Then With rngToProc.Offset(RR - 1, CC - 1).Range(posToFilWithN(NN - 1)) If .Value = "" Then .Value = "n" End If End With End If Next CC Next RR Next NN End Sub '標準モジュールはここまで '＜城国クラスのモジュールに貼り付けるコード＞-------------------------------------------- 'Option Explicit Private own国王 As String 'ヒミコがConqueror Private own国ID As Long Private own座標 As String Private own北緯 '行 Private own東経 '列 Private own隣接座標(1 To 4) Private own同国域(1 To 4) As Long Private ownCellVal 'セル値 Public Property Get 同国域() 同国域 = own同国域 End Property Public Property Get CellVal() CellVal = ownCellVal End Property Public Property Let 国王(国王名) own国王 = 国王名 End Property Public Property Get 国王() 国王 = own国王 End Property Public Property Get 座標Key() 座標Key = own座標 End Property Public Property Get 国ID() 国ID = own国ID End Property Rem 隣接国を調べる Public Sub 隣接国征服(ByRef 未征服国の座標登記所 As Object, ByRef 国々) Dim 隣国ID As Long, KK As Long For KK = 1 To 4 If 未征服国の座標登記所.exists(own隣接座標(KK)) Then ' 上右下左 隣国ID = 未征服国の座標登記所(own隣接座標(KK)) '隣国のID If 国々(隣国ID).国王 <> "ヒミコ" Then 同国域化 = KK '同国域フラグを立てる 国々(隣国ID).同国域化 = KK + IIf(KK < 3, 2, -2) 国々(隣国ID).国王 = "ヒミコ" '新国王にする Call 未征服国の座標登記所.Remove(own隣接座標(KK)) '未征服国から削除 Call 国々(隣国ID).隣接国征服(未征服国の座標登記所, 国々) '再起処理 End If End If Next KK End Sub Public Property Let 同国域化(KK As Long) own同国域(KK) = 1 End Property Rem 未征服国までの距離を算出する Public Property Get 最近傍国DATA(ByRef 未征服国の座標登記所) Dim trialDist As Long Dim shortestDist As Long Dim 近傍国ID Dim 残国座標 Dim temp座標 '北緯、東経 shortestDist = 10000000 For Each 残国座標 In 未征服国の座標登記所.Keys '残国Keyを順次取得 temp座標 = Split(残国座標) trialDist = Abs(temp座標(0) - own北緯) + Abs(temp座標(1) - own東経) If trialDist < shortestDist Then shortestDist = trialDist 最近傍国DATA = Join(Array(shortestDist, 残国座標), "#") End If Next End Property Public Sub setInitialInfo(originalID, row, col, 地域Num) own国ID = originalID own座標 = row & " " & col own北緯 = row own東経 = col ownCellVal = 地域Num own隣接座標(1) = row - 1 & " " & col own隣接座標(2) = row & " " & col + 1 own隣接座標(3) = row + 1 & " " & col own隣接座標(4) = row & " " & col - 1 End Sub 'クラスモジュールは、ここまで------------------------ （半平太） 2014/08/09(土) 15:54 ---- 試してみました! G6に余分そうな「n」があるのは、F6にnを置いたときに必要だからですかね? [A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [1] 1 [2] 17 n [3] 11 n n 5 n 14 12 [4] 2 n [5] 10 [6] 3 n 13 [7] 6 n 0 n 8 n n n [8] n n 18 [9] 9 n 15 n [10] 7 20 （稲葉） 2014/08/11(月) 09:05 ---- ＞ 試してみました! お粗末(と判明した）案をテストいただき恐縮です。m(__)m ＞ G6に余分そうな「n」があるのは、F6にnを置いたときに必要だからですかね? そんな大それたロジックは組んでおりません。 「一番近くにいる豪族を襲撃する」と云うだけの仕様です。 ご提示の例ができた原因は、ヒミコ軍(13)の一番近くにいる豪族は8と18の二つです。(どちらも道路を2つ作れば到達します） 現在のロジックでは、エクセルシート上で、より上、より左にいる豪族を優先的に襲撃します。つまり、8の襲撃を決定します。 （この時点で占い師を登場させれば結果は変わりもしますが、やっつけ仕事なんで・・いや、仕事でもない） 8の豪族は左2、下1つの位置にいるので、先ず、開きの大きい「左方向(G6）」に軍用道路を1つ造ります。 まだ8に到達できないので、その道路からもう一度8の位置を確認します。 すると、今度は左1、下1の位置に近づいています。 今度は左右・上下どっちも同じ距離(1）なので、方向が決められません。 いつも同じ反応をしてはダンゴ虫と同じでいつも同じ結果につながってしまうので、 ここで占い師に左右の吉凶を訊ねます。 その時のお告げがたまたま「下に進め」だった。(「そのまま進め」となる事もありえます） 8の豪族を平定してしまうと、最も近くにいるのは18の豪族に変わり、それは下2、右1の位置なので下を優先してH7へ侵攻・・・ ・・・と云う経緯で、そんな結果が出てきます。 H7への侵攻をI6セルにしたとすると、見た目はダブり感がなくなりますが、1つ余分であることには変わりないです。 「正解に近づけるため、G6のnを取り去る方策はないか」と考えるのが近似解案の採るべき態度と云えそうです。 上の方で書いた「占い師の早期登場」と合わせて2つ改善策が考えられますね。でも、仕事じゃないので、やりませんけど・・・ （半平太） 2014/08/11(月) 10:40 ---- お返事ありがとうございます。 全部みたわけじゃないのですが、F8をぽちぽち押しながら楽しく読み解いてみます。 ＞「正解に近づけるため、G6のnを取り去る方策はないか」と考えるのが近似解案の採るべき態度と云えそうです。 全豪族を平定した後、今度は城壁を固めるため外堀を「埋める」（掘る?）のが得策ってことですね! 大変勉強になりました。 （稲葉） 2014/08/11(月) 13:28 ---- 稲葉さんの勉強になるようなものは作れません。 ＞全豪族を平定した後、今度は城壁を固めるため外堀を「埋める」（掘る?）のが得策ってことですね! その通りです。 出来上がり図から、nを一つずつ取り去って、それでもオリジナルの数字が 全部つながっているなら、そのnは不要道路なので捨てていくと云う案です。 既に、隣接国の洗い出しができる仕掛けがあるので、 修正はそんなに難しくないであろうとは思っておりますが、 なにせ質問自体が、本当にそれでいいのぉと云う要件に思え、 多分仕様変更があるんだろうなぁと思っているので、 よっぽど暇じゃないと取り組む気が起きないです。 ただし、私自身の勉強になったところはありました。(現在進行形ですけど） 久しぶりに構造体を使って距離と座標を別々に返そうと思ったのですが、 旨くいかず、Stringで繋げてお茶を濁してしまった。(^_^;) ※征服候補国DATAと征服国DATA このエラーが分かんないです。 「コンパイルエラー パブリックオブジェクトモジュールで定義された ユーザー定義型に限り、変数に割り当てることができ、 実行時バインディングの関数を渡すことができます。」 Public Type は標準moduleに宣言したのですけど 旨くコンパイルできないです。何回もテストしているとフリーズして 時間のロスがひどいのでテストを中止しています。 （半平太） 2014/08/11(月) 15:21 ---- 半平太さんのように格好よくできませんが、一応、考えがまとまって以下にマクロをUPできるかな〜、の状態になりました。 ただし、現在は初期ポイントの数が36迄としています。それ以上も可能は可能ですが... また、数学的にこれで正しいのかどうかは、不明です。(^^ゞ（ならするな!と叱られそうですが） 部分最適が全体最適に等しいかどうか、疑問を持ちつつも、縦横の世界なので、これで良さそうだと思います。 解を求めるために、ワークのシートを使っています。 以下、マクロです。もう少し簡素に書けると良いのですが.... ============================================== Option Explicit Sub まとめ() Dim OSht, TSht As Worksheet Dim Idx, IIMx, JJMx, 最小値 As Integer Dim I, J, S As Integer ' Set OSht = ActiveSheet Idx = OSht.Index Sheets.Add After:=Sheets(Idx) Set TSht = ActiveSheet OSht.Activate Call 数字置き直し(OSht, IIMx, JJMx) '同一の数字があると処理できないので、勝手に置き換え （36ポイントまで） 最小値 = 0 While 最小値 <> 999 'Loop Call A座標計算(OSht, TSht, IIMx, JJMx) Call B相対距離計算(OSht, TSht) Call C最小値探索(最小値, TSht) If 最小値 <> 999 Then Call D同一ブロック集め(TSht) Call C最小値探索(最小値, TSht) Call E評価設定(OSht, TSht) End If Wend S = 0 For I = 1 To IIMx For J = 1 To JJMx If OSht.Cells(I, J) <> "" Then S = S + 1 End If Next J Next I OSht.Activate MsgBox "求める面積は図のようになり" & S & "です。", vbOKOnly, "面積" End Sub Sub 数字置き直し(OSht, IMx, JMx) ' 元のシートの数字を置き換える。36個までが限界 Dim I, J, K As Integer Dim Ch As Variant Ch = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ" With OSht.UsedRange IMx = .Cells(.Count).Row JMx = .Cells(.Count).Column End With K = 0 For I = 1 To IMx For J = 1 To JMx If OSht.Cells(I, J) <> "" Then K = K + 1 OSht.Cells(I, J) = Mid(Ch, K, 1) End If Next J Next I End Sub Sub A座標計算(OSht, TSht, IIMx, JJMx) ' 元のシートから座標を得て、表にする。 Dim I, J, K, L, M, N, Wi, Wj As Integer Dim IMx, JMx As Integer Dim Flg As Boolean TSht.Select K = 1 For I = 1 To IIMx For J = 1 To JJMx If OSht.Cells(I, J) <> "" Then If TSht.Cells(K + 1, 1) = "" Then TSht.Cells(K + 1, 1) = OSht.Cells(I, J) K = K + 1 N = N + 1 Else Flg = 0 GoSub データ探索 If Flg = 0 Then TSht.Rows(K + 1).Insert shift:=xlDown TSht.Range(Columns(3 * K - 1), Columns(3 * K + 1)).Insert shift:=xlToRight TSht.Cells(K + 1, 1) = OSht.Cells(I, J) End If K = K + 1 N = N + 1 End If End If Next J Next I K = 0 For I = 1 To N With TSht.Cells(1, I * 3 - 1) .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Range(TSht.Cells(1, I * 3 - 1), TSht.Cells(1, I * 3 + 1)).Merge TSht.Cells(1, I * 3 - 1) = TSht.Cells(I + 1, 1) Next I Wi = N * 3 + 8 Wj = N * 3 + 9 TSht.Cells(1, Wi) = "Wi" TSht.Cells(1, Wj) = "Wj" For J = 1 To 4 Range(TSht.Cells(1, Wj + J * 5 - 4), TSht.Cells(1, Wj + J * 5 - 3)).Merge TSht.Cells(1, Wj + J * 5 - 4) = "方向" & StrConv(Trim(Str(J)), vbWide) TSht.Cells(1, Wj + J * 5 - 2) = "個数" & StrConv(Trim(Str(J)), vbWide) TSht.Cells(1, Wj + J * 5 - 1) = "面積" & StrConv(Trim(Str(J)), vbWide) TSht.Cells(1, Wj + J * 5) = "色" & StrConv(Trim(Str(J)), vbWide) Next J With Rows(1) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With For I = 1 To IIMx For J = 1 To JJMx If OSht.Cells(I, J) <> "" Then GoSub データ探索 TSht.Cells(L, Wi) = I TSht.Cells(L, Wj) = J End If Next J Next I IMx = TSht.Range("A" & Rows.Count).End(xlUp).Row JMx = TSht.Cells(1, 16384).End(xlToLeft).Column TSht.Range(Cells(2, IMx * 3 + 4), Cells(IMx, IMx * 3 + 4)).ClearContents '方向他クリア Range(TSht.Cells(2, IMx * 3 + 7), TSht.Cells(IMx, JMx)).ClearContents '面積クリア Exit Sub データ探索: For L = 2 To Range("A" & Rows.Count).End(xlUp).Row If TSht.Cells(L, 1) = OSht.Cells(I, J) Then Flg = 1 Exit For End If Next L Return End Sub Sub B相対距離計算(OSht, TSht) ' 表について、各ポイントの相対距離を計算する。 Dim I, J, Wi, Wj, IMx, JMx As Integer IMx = 0 JMx = 0 Application.ScreenUpdating = False I = 1 J = 2 While TSht.Cells(1, I) <> "Wi" I = I + 1 If TSht.Cells(J, 1) <> "" Then IMx = IMx + 1 JMx = JMx + 1 J = J + 1 End If Wend Wi = I Wj = Wi + 1 For I = 2 To IMx + 1 For J = 2 To JMx + 1 If I <> J Then TSht.Cells(I, J * 3 - 4) = TSht.Cells(J, Wi) - TSht.Cells(I, Wi) TSht.Cells(I, J * 3 - 3) = TSht.Cells(J, Wj) - TSht.Cells(I, Wj) TSht.Cells(I, J * 3 - 2) = Abs(TSht.Cells(I, Wi) - TSht.Cells(J, Wi)) + Abs(TSht.Cells(I, Wj) - TSht.Cells(J, Wj)) - 1 End If Next J Next I With TSht.Range(Cells(2, 2), Cells(IMx + 1, 3 * JMx + 1)).Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Cells.EntireColumn.AutoFit Application.ScreenUpdating = True End Sub Sub C最小値探索(MinS, TSht) ' 表内の最小値を求める。 Dim I, J, K, L, MinI, MinJ, Ws, IMx, JMx As Integer Dim Di, Dj, Dc, Dq, Ds As Integer JMx = Range("A" & Rows.Count).End(xlUp).Row - 1 IMx = JMx With TSht.Range(Cells(2, 1), Cells(IMx + 1, 1)).Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With TSht.Range(Cells(1, 2), Cells(1, 3 * JMx + 1)).Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Call Block認識(IMx, JMx, TSht) '隣接部分同一プロックの認識で色分けする。 MinS = 999 For I = 2 To IMx '最小値、場所サーチ For J = 2 To JMx + 1 If J <> I Then If TSht.Cells(I, J * 3 - 2) = 0 Then Range(TSht.Cells(I, J * 3 - 4), TSht.Cells(I, J * 3 - 2)).Interior.ColorIndex = 6 Else If TSht.Cells(I, J * 3 - 2) < MinS Then If TSht.Cells(I, 1).Interior.ColorIndex <> -4142 Then If TSht.Cells(I, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex Then '同一ブロック内では最小値を求めない MinS = TSht.Cells(I, J * 3 - 2) MinI = I MinJ = J End If Else MinS = TSht.Cells(I, J * 3 - 2) MinI = I MinJ = J End If End If End If End If Next J Next I If MinS <> 999 Then Range(TSht.Cells(MinI, MinJ * 3 - 4), TSht.Cells(MinI, MinJ * 3 - 2)).Interior.ColorIndex = 34 For I = 2 To IMx + 1 For J = 2 To JMx + 1 If TSht.Cells(I, J * 3 - 2) = MinS Then If TSht.Cells(I, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex Or TSht.Cells(I, 1).Interior.ColorIndex = -4142 Then Range(TSht.Cells(I, J * 3 - 4), TSht.Cells(I, J * 3 - 2)).Interior.ColorIndex = 34 GoSub 方向面積計算 End If End If Next J Next I End If Exit Sub 方向面積計算: If TSht.Cells(1, JMx * 3 + 7) = "S" Then If TSht.Cells(I, J * 3 - 4) = 0 Then Di = 0 Dj = TSht.Cells(I, J * 3 - 3) If Dj < 0 Then Dj = Dj + 1 Else Dj = Dj - 1 End If Dq = TSht.Cells(I, J * 3 - 2) GoSub 周囲チェック Ds = TSht.Cells(J, JMx * 3 + 7) If Ds = 0 Then Ds = 1 End If Dc = TSht.Cells(J, 1).Interior.ColorIndex GoSub 方向面積格納 ElseIf TSht.Cells(I, J * 3 - 3) = 0 Then Di = TSht.Cells(I, J * 3 - 4) If Di < 0 Then Di = Di + 1 Else Di = Di - 1 End If Dj = 0 Dq = TSht.Cells(I, J * 3 - 2) Ds = TSht.Cells(J, JMx * 3 + 7) If Ds = 0 Then Ds = 1 End If Dc = TSht.Cells(J, 1).Interior.ColorIndex GoSub 方向面積格納 Else Di = TSht.Cells(I, J * 3 - 4) If Di < 0 Then Di = Di + 1 Else Di = Di - 1 End If Dj = TSht.Cells(I, J * 3 - 3) Dq = TSht.Cells(I, J * 3 - 2) Ds = TSht.Cells(J, JMx * 3 + 7) If Ds = 0 Then Ds = 1 End If Dc = TSht.Cells(J, 1).Interior.ColorIndex GoSub 方向面積格納 Di = TSht.Cells(I, J * 3 - 4) Dj = TSht.Cells(I, J * 3 - 3) If Dj < 0 Then Dj = Dj + 1 Else Dj = Dj - 1 End If GoSub 方向面積格納 End If End If Return 周囲チェック: Return 方向面積格納: For L = JMx * 3 + 10 To JMx * 3 + 25 Step 5 If (TSht.Cells(I, L) = 0 And TSht.Cells(I, L + 1) = 0) Or (TSht.Cells(I, L) = "" And TSht.Cells(I, L + 1) = "") Then TSht.Cells(I, L) = Di TSht.Cells(I, L + 1) = Dj TSht.Cells(I, L + 2) = 1 TSht.Cells(I, L + 3) = Ds If Dc = -4142 Then Dc = "" End If TSht.Cells(I, L + 4) = Dc Exit For ElseIf TSht.Cells(I, L) = Di And TSht.Cells(I, L + 1) = Dj Then If Dc = -4142 Then Dc = "" End If If Dc = "" Or TSht.Cells(I, L + 4) <> Dc Then TSht.Cells(I, L + 2) = TSht.Cells(I, L + 2) + 1 TSht.Cells(I, L + 3) = TSht.Cells(I, L + 3) + Ds End If TSht.Cells(I, L + 4) = Dc Exit For End If Next L Return End Sub Sub Block認識(IMx, JMx, TSht) Dim Blk1, Blk2, ColI, ColJ, ColK As Integer Dim I, J, K As Integer Dim ColPat As Variant Dim ColP(21) As Variant ColPat = "0304060708223334353637383940414243444546" For I = 1 To 20 ColP(I) = Mid(ColPat, I * 2 - 1, 2) Next I ColI = 0 For I = 2 To IMx + 1 For J = I + 1 To JMx + 1 If TSht.Cells(I, J * 3 - 2) = 0 Then Blk1 = I Blk2 = J If TSht.Cells(Blk1, 1).Interior.ColorIndex = -4142 Then If TSht.Cells(Blk2, 1).Interior.ColorIndex = -4142 Then ColI = ColI + 1 TSht.Cells(Blk1, 1).Interior.ColorIndex = ColP(ColI) TSht.Cells(Blk2, 1).Interior.ColorIndex = ColP(ColI) Range(TSht.Cells(1, Blk1 * 3 - 4), TSht.Cells(1, Blk1 * 3 - 2)).Interior.ColorIndex = ColP(ColI) Range(TSht.Cells(1, Blk2 * 3 - 4), TSht.Cells(1, Blk2 * 3 - 2)).Interior.ColorIndex = ColP(ColI) Else ColJ = TSht.Cells(Blk2, 1).Interior.ColorIndex TSht.Cells(Blk1, 1).Interior.ColorIndex = ColJ Range(TSht.Cells(1, Blk1 * 3 - 4), TSht.Cells(1, Blk1 * 3 - 2)).Interior.ColorIndex = ColJ End If Else ColJ = TSht.Cells(Blk1, 1).Interior.ColorIndex If TSht.Cells(Blk2, 1).Interior.ColorIndex = -4142 Then TSht.Cells(Blk2, 1).Interior.ColorIndex = ColJ Range(TSht.Cells(1, Blk2 * 3 - 4), TSht.Cells(1, Blk2 * 3 - 2)).Interior.ColorIndex = ColJ Else ColK = TSht.Cells(Blk2, 1).Interior.ColorIndex TSht.Cells(Blk2, 1).Interior.ColorIndex = ColJ Range(TSht.Cells(1, Blk2 * 3 - 4), TSht.Cells(1, Blk2 * 3 - 2)).Interior.ColorIndex = ColJ For K = 2 To IMx + 1 If TSht.Cells(K, 1).Interior.ColorIndex = ColK Then TSht.Cells(K, 1).Interior.ColorIndex = ColJ Range(TSht.Cells(1, K * 3 - 4), TSht.Cells(1, K * 3 - 2)).Interior.ColorIndex = ColJ End If Next K End If End If End If Next J Next I End Sub Sub D同一ブロック集め(TSht) Dim I, J, K, ColI, IMx, StI, EdI, Sq As Integer Dim DifFlg As Boolean IMx = TSht.Range("A" & Rows.Count).End(xlUp).Row For I = 2 To IMx If TSht.Cells(I, 1).Interior.ColorIndex <> -4142 Then ColI = TSht.Cells(I, 1).Interior.ColorIndex K = I + 1 DifFlg = 0 For J = I + 1 To IMx If TSht.Cells(J, 1).Interior.ColorIndex = ColI Then If DifFlg <> 0 Then If J > K Then TSht.Rows(J).Cut TSht.Rows(K).Insert shift:=xlDown TSht.Range(Columns(J * 3 - 4), Columns(J * 3 - 2)).Cut TSht.Columns(K * 3 - 4).Insert shift:=xlToRight K = K + 1 End If End If Else DifFlg = 1 End If Next J I = K - 1 End If Next I For I = 2 To IMx TSht.Cells(I, IMx * 3 + 4) = "" Next I I = 2 TSht.Cells(1, IMx * 3 + 4) = "S" While I <= IMx If TSht.Cells(I, 1).Interior.ColorIndex <> -4142 Then StI = I Sq = 0 For J = I + 1 To IMx If TSht.Cells(J, 1).Interior.ColorIndex <> TSht.Cells(I, 1).Interior.ColorIndex Then EdI = J - 1 For K = StI To EdI TSht.Cells(K, IMx * 3 + 4) = Sq + 1 Next K Exit For Else Sq = Sq + 1 End If Next J I = J Else I = I + 1 End If Wend If StI <> 0 Then EdI = J - 1 For K = StI To EdI TSht.Cells(K, IMx * 3 + 4) = Sq + 1 Next K End If End Sub Sub E評価設定(OSht, TSht) Dim SPi(100), SPj(100), Sj(100) As Integer '同一面積、同一個数、の場合の評価テーブル（最大100） Dim I, J, K, L, M, IMx, JMx, SMx, Smx1, KMx, Ip, Jp, S4Ip, S4Jp, NMx, Si, Sk, Ki, AbsM As Integer Dim Wi, Wj, SMin, SMinI As Integer Dim S4Dr1, S4Dr1S, S4Dr1Q, S4Dr2, S4Dr2S, S4Dr2Q As Integer Dim SMi(4), SMj(4) As Integer Dim Col, ColCnt As Integer ' 評価 IMx = TSht.Range("A" & Rows.Count).End(xlUp).Row JMx = IMx * 3 + 7 Wi = JMx - 2 Wj = JMx - 1 SMx = 0 Si = 0 KMx = 0 NMx = 1 For I = 2 To IMx '評価 For J = JMx + 3 To JMx + 18 Step 5 If SMx < TSht.Cells(I, J) Then If KMx <= TSht.Cells(I, J - 1) Then SMx = TSht.Cells(I, J) '面積 KMx = TSht.Cells(I, J - 1) '個数 Ip = I Jp = J Si = 1 '同一面積、個数、評価用 SPi(Si) = I SPj(Si) = J End If ElseIf SMx = TSht.Cells(I, J) And SMx <> 0 Then If KMx = TSht.Cells(I, J - 1) And KMx <> 0 Then Si = Si + 1 '同一面積、個数、評価用 SPi(Si) = I SPj(Si) = J End If End If Next J If Left(TSht.Cells(I, 1), 1) = "n" Then '現在のnの番号Get NMx = NMx + 1 End If Next I If Si <> 1 Then GoSub 対抗場所特定 GoSub 多重評価 S4Ip = TSht.Cells(SPi(Sk), Wi) S4Jp = TSht.Cells(SPi(Sk), Wj) S4Dr1 = TSht.Cells(SPi(Sk), SPj(Sk) - 3) If S4Dr1 < 0 Then S4Dr1S = -1 S4Dr1Q = S4Dr1 * (-1) ElseIf S4Dr1 > 0 Then S4Dr1S = 1 S4Dr1Q = S4Dr1 Else S4Dr1S = 0 S4Dr1Q = 0 End If S4Dr2 = TSht.Cells(SPi(Sk), SPj(Sk) - 2) If S4Dr2 < 0 Then S4Dr2S = -1 S4Dr2Q = S4Dr2 * (-1) ElseIf S4Dr2 > 0 Then S4Dr2S = 1 S4Dr2Q = S4Dr2 Else S4Dr2S = 0 S4Dr2Q = 0 End If If S4Dr1 <> 0 And S4Dr2 <> 0 Then GoSub 経路評価 ElseIf S4Dr1 <> 0 And S4Dr2 = 0 Then For I = 1 To S4Dr1Q OSht.Cells(S4Ip + S4Dr1S, S4Jp) = "n" & Trim(Str(NMx)) S4Ip = S4Ip + S4Dr1S NMx = NMx + 1 Next I ElseIf S4Dr1 = 0 And S4Dr2 <> 0 Then For J = 1 To S4Dr2Q OSht.Cells(S4Ip, S4Jp + S4Dr2S) = "n" & Trim(Str(NMx)) S4Jp = S4Jp + S4Dr2S NMx = NMx + 1 Next J End If Else S4Ip = TSht.Cells(Ip, Wi) S4Jp = TSht.Cells(Ip, Wj) S4Dr1 = TSht.Cells(Ip, Jp - 3) If S4Dr1 < 0 Then S4Dr1S = -1 S4Dr1Q = S4Dr1 * (-1) ElseIf S4Dr1 > 0 Then S4Dr1S = 1 S4Dr1Q = S4Dr1 Else S4Dr1S = 0 S4Dr1Q = 0 End If S4Dr2 = TSht.Cells(Ip, Jp - 2) If S4Dr2 < 0 Then S4Dr2S = -1 S4Dr2Q = S4Dr2 * (-1) ElseIf S4Dr2 > 0 Then S4Dr2S = 1 S4Dr2Q = S4Dr2 Else S4Dr2S = 0 S4Dr2Q = 0 End If OSht.Cells(S4Ip + S4Dr1S, S4Jp + S4Dr2S) = "n" & Trim(Str(NMx)) End If Exit Sub 対抗場所特定: For K = 1 To Si If SMx = TSht.Cells(SPi(K), SPj(K)) Then I = SPi(K) For J = 2 To IMx If TSht.Cells(I, J * 3 - 2).Interior.ColorIndex = 34 Then If K <> 1 And J <> Sj(K - 1) Then Sj(K) = J Exit For ElseIf K = 1 Then Sj(K) = J Exit For End If End If Next J If Sj(K) = 0 Then Sj(K) = Sj(K - 1) End If End If Next K Return 多重評価: Col = TSht.Cells(2, 1).Interior.ColorIndex ColCnt = 1 For I = 3 To IMx If TSht.Cells(I, 1).Interior.ColorIndex = -4142 Then ColCnt = ColCnt + 1 Else If TSht.Cells(I, 1).Interior.ColorIndex <> Col Then If TSht.Cells(I, 1).Interior.ColorIndex <> -4142 Then Col = TSht.Cells(I, 1).Interior.ColorIndex End If ColCnt = ColCnt + 1 End If End If Next I Smx1 = 999 For K = 1 To Si If SMx = TSht.Cells(SPi(K), SPj(K)) Then I = SPi(K) If ColCnt <> 2 Then For J = 2 To IMx If I <> J Then M = Sj(K) If TSht.Cells(I, 1).Interior.ColorIndex = -4142 Then If TSht.Cells(M, 1).Interior.ColorIndex = -4142 Then GoSub 次小データ調査 ElseIf TSht.Cells(M, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex Then GoSub 次小データ調査 End If Else If TSht.Cells(M, 1).Interior.ColorIndex = -4142 Then If TSht.Cells(J, 1).Interior.ColorIndex = -4142 Then GoSub 次小データ調査 ElseIf TSht.Cells(I, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex Then GoSub 次小データ調査 End If Else If TSht.Cells(J, 1).Interior.ColorIndex = -4142 Then If TSht.Cells(M, 1).Interior.ColorIndex = -4142 Then GoSub 次小データ調査 Else If TSht.Cells(M, 1).Interior.ColorIndex <> TSht.Cells(I, 1).Interior.ColorIndex Then GoSub 次小データ調査 End If End If Else If TSht.Cells(M, 1).Interior.ColorIndex <> TSht.Cells(I, 1).Interior.ColorIndex _ And (TSht.Cells(M, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex) _ And (TSht.Cells(I, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex) Then GoSub 次小データ調査 End If End If End If End If End If Next J Else Ki = I End If End If Next K AbsM = 999 For K = 1 To Si If SMx = TSht.Cells(SPi(K), SPj(K)) Then If SPi(K) = Ki Then If AbsM > Abs(Ip - TSht.Cells(SPi(K), SPj(K) - 3)) + Abs(Jp - TSht.Cells(SPi(K), SPj(K) - 2)) Then AbsM = Abs(Ip - TSht.Cells(SPi(K), SPj(K) - 3)) + Abs(Jp - TSht.Cells(SPi(K), SPj(K) - 2)) Sk = K End If End If End If Next K Return 次小データ調査: If I <> J Then If Smx1 > TSht.Cells(I, J * 3 - 2) Then '次に一番小さい間を調べる Smx1 = TSht.Cells(I, J * 3 - 2) Ip = TSht.Cells(I, J * 3 - 4) Jp = TSht.Cells(I, J * 3 - 3) Ki = I End If End If Return 経路評価: SMi(1) = S4Ip + Ip SMj(1) = S4Jp SMi(2) = S4Ip SMj(2) = S4Jp + Jp SMin = 999 I = SPi(Sk) For J = 2 To IMx If TSht.Cells(I, J * 3 - 2).Interior.ColorIndex <> 34 Then If TSht.Cells(I, 1).Interior.ColorIndex <> TSht.Cells(J, 1).Interior.ColorIndex Then '??? If TSht.Cells(I, J * 3 - 2) < SMin Then SMin = TSht.Cells(I, J * 3 - 2) SMinI = J End If End If End If Next J If Abs(TSht.Cells(SMinI, Wi) - SMi(1)) + Abs(TSht.Cells(SMinI, Wj) - SMj(1)) > _ Abs(TSht.Cells(SMinI, Wi) - SMi(2)) + Abs(TSht.Cells(SMinI, Wj) - SMj(2)) Then For I = 1 To S4Dr2Q OSht.Cells(S4Ip, S4Jp + S4Dr2S) = "n" & Trim(Str(NMx)) S4Jp = S4Jp + S4Dr2S NMx = NMx + 1 Next I For I = 1 To S4Dr1Q OSht.Cells(S4Ip + S4Dr1S, S4Jp) = "n" & Trim(Str(NMx)) S4Ip = S4Ip + S4Dr1S NMx = NMx + 1 Next I Else For I = 1 To S4Dr1Q OSht.Cells(S4Ip + S4Dr1S, S4Jp) = "n" & Trim(Str(NMx)) S4Ip = S4Ip + S4Dr1S NMx = NMx + 1 Next I For I = 1 To S4Dr2Q OSht.Cells(S4Ip, S4Jp + S4Dr2S) = "n" & Trim(Str(NMx)) S4Jp = S4Jp + S4Dr2S NMx = NMx + 1 Next I End If Return End Sub （パオ〜〜ン） 2014/09/01(月) 13:54... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201408/20140805153308.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 96999 documents and 607826 words.
訪問者：