[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセルシートで面積を求めたい。』（ひらみの）
エクセルシートを地図に見立て、面積を割り出したいと思います。
1セルは高さ幅とも1kmとします。（つまり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 ＞
ありがとうございます。
ｎのプロットは最少になるように求めたい。 最少でも複数のパターンが存在する場合は、そのパターンも知りたいのですが、まずは最少のｎの数がわかればと思います。
マクロを組むイメージとしては数値1〜6を地形図の山頂と見立て、山頂を一斉に1段ずつ標高上げる。 その際、上下左右に1セル分の道を作る。山頂からのルートが上下左右とも行き止まりの場合は、さらに1段上げ、ルートを広げる。 そして全てのセル（山頂）がつながった時点で、行き止まりのコースは消去する。 残ったコースが複数パターンある場合は、任意の1つのみ残す。 任意の山頂から全ての山を回るに当たり、できるだけ切り開く道を少なくする。
余計イメージがわかりにくいでしょうか？ エクセルというより、ゲームソフトの開発のようになってしまいました。 （ひらみの） 2014/08/06(水) 10:12
その説明だとD3:F3がnになると思うのですが・・・ 「任意」ということは「人の手」ってことなら最初から手でやったほうがよっぽど早いような。
（稲葉） 2014/08/06(水) 13:11
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
としてもできます。面積はどちらも１０ですが、
それを求めるロジックが、超難しそう(*_*)
（パオ〜〜ン） 2014/08/07(木) 16:36
あちらでもコメントでも触れられていますが、最適解は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
貼り付けるコード(標準モジュール用とクラスモジュール用があります）
※貼り付けに先立って、クラスモジュールを１枚挿入して、 表示→プロパティウィンドウ からオブジェクト名を「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のｎを取り去る方策はないか」と考えるのが近似解案の採るべき態度と云えそうです。
上の方で書いた「占い師の早期登場」と合わせて2つ改善策が考えられますね。でも、仕事じゃないので、やりませんけど・・・
（半平太） 2014/08/11(月) 10:40
お返事ありがとうございます。 全部みたわけじゃないのですが、F8をぽちぽち押しながら楽しく読み解いてみます。
＞「正解に近づけるため、G6のｎを取り去る方策はないか」と考えるのが近似解案の採るべき態度と云えそうです。 全豪族を平定した後、今度は城壁を固めるため外堀を「埋める」（掘る？）のが得策ってことですね！
大変勉強になりました。
（稲葉） 2014/08/11(月) 13:28
稲葉さんの勉強になるようなものは作れません。
＞全豪族を平定した後、今度は城壁を固めるため外堀を「埋める」（掘る？）のが得策ってことですね！ その通りです。 出来上がり図から、ｎを一つずつ取り去って、それでもオリジナルの数字が 全部つながっているなら、そのｎは不要道路なので捨てていくと云う案です。
既に、隣接国の洗い出しができる仕掛けがあるので、 修正はそんなに難しくないであろうとは思っておりますが、 なにせ質問自体が、本当にそれでいいのぉと云う要件に思え、 多分仕様変更があるんだろうなぁと思っているので、 よっぽど暇じゃないと取り組む気が起きないです。
ただし、私自身の勉強になったところはありました。(現在進行形ですけど） 久しぶりに構造体を使って距離と座標を別々に返そうと思ったのですが、 旨くいかず、Stringで繋げてお茶を濁してしまった。(^_^;) ※征服候補国DATAと征服国DATA
このエラーが分かんないです。 「コンパイルエラー パブリックオブジェクトモジュールで定義された ユーザー定義型に限り、変数に割り当てることができ、 実行時バインディングの関数を渡すことができます。」
Public Type は標準moduleに宣言したのですけど 旨くコンパイルできないです。何回もテストしているとフリーズして 時間のロスがひどいのでテストを中止しています。
（半平太） 2014/08/11(月) 15:21
ただし、現在は初期ポイントの数が３６迄としています。それ以上も可能は可能ですが...
また、数学的にこれで正しいのかどうかは、不明です。(^^ゞ（ならするな！と叱られそうですが）
部分最適が全体最適に等しいかどうか、疑問を持ちつつも、縦横の世界なので、これで良さそうだと思います。
解を求めるために、ワークのシートを使っています。
以下、マクロです。もう少し簡素に書けると良いのですが....
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
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) '同一の数字があると処理できないので、勝手に置き換え （３６ポイントまで）
最小値 = 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)
' 元のシートの数字を置き換える。３６個までが限界
Dim I, J, K As Integer
Dim Ch As Variant
Ch = "１２３４５６７８９ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＰＱＲＳＴＵＶＷＸＹＺ"
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 '同一面積、同一個数、の場合の評価テーブル（最大１００）
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 '現在のｎの番号Ｇｅｔ
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.