[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『指定行内での指定内容の検索 系譜図上』（はんにゃ）
今
Sheets("系譜図")のxrbセル行番号の行内で 配列データtbl1(irg, 1)を検索して、
その存在するセル列番号xcb を出力するコードをご教授お願いします
xcb =Sheets("系譜図").Rows(Cells(xrb,１).Address).Find(What:=tbl1(irg, 1))
マクロ記録やHelp参照して 書いたこのコードはうまくいきません。
ここで Cells（xrb，１)の行Rows()の表現とか .Find()のコードの記述などが問題のようで エラーがでます。
また 複数該当セルがあったときは
If MsgBox("the same ? " & Cells(xrb,xcb) & "with" & tbl1(irg, 1), vbYesNo) = vbYes Then
Elseif '同じ質問
Endif
と手動の確認する予定です
なお、 Dim tbl1 Dim xrb As Long で sheetsの"D2"が 行列番号の(1,1)となっています。 xrb = tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
＞マクロ記録やHelp参照 も強力な武器になりますが、Web検索するのも良いと思います。
校内に限ったことにすれば、↓の様な全文検索をすると http://www.excel.studio-kazu.jp/cgi-bin/estindex/estseek2.cgi?phrase=%E6%A4%9C%E7%B4%A2%E3%80%80%E5%88%97++.Find%28What%3A%3D&perpage=10&attr=@uri+STRINC+kazuwiki&order=@uri+STRD&clip=-1&navi=0
↓の過去ログが見つかります。 [[20090208103047]]『コードを検索して表を転記したい』（たかなし）
あとは、この前も紹介させて頂きましたが http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_find.html よねさんのWordとExcelの小部屋 Excel(エクセル)VBA入門：Findメソッド,Like演算子を使った検索
それから、単純に考えると
１行目は Rows("1:1")と書くのですから
xrbの行は Rows( xrb & ":" & xrb ) ではないでしょうか？
(HANA)
手動でやっていること（列幅調整、家紋図像の貼り付けなど）をすこしづつ 自動化マクロ化していました。 現在は 関係者（特に直系でない 傍系になった 子と その婚姻関係）のセルを描画線で結びたく 奮戦（？）しています。
手動でするときの 頭の整理（どういう論理）が不確かで やりながらという悪い仕方をまた取っています。これは入力の仕方もやむなく関係して 制約が追加するかもしれません。
とりあえず 検索する方法を以下のように 作ってみました。この限りでは 正常動作します。
この結果から 次は その生年の行内で 該当名前をさがし そのセルの再探索する という2段階目です。 但し 婚姻の一方の親（入力で2番目に記載）では必ずしも 生年の行にないので ややこしいです
Rowsの代わりにColumnsで小手調べです。
Sub kensakuMojiretu2()
Dim ret As String
ret = InputBox("検索文字列を入力して下さい。")
If Len(ret) = 0 Then
MsgBox "キャンセルされました"
Exit Sub
End If
With Sheets("データ表").Columns("A")
'Sheets("データ表").Columns(xrb & ":" & xrb).Select
Set c = .Find(ret, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
MsgBox c.Address & "行に" & c.Value & "があります"
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Sub kensakuMojiretu()
Dim ret As String
ret = InputBox("検索文字列を入力して下さい。")
If Len(ret) = 0 Then
MsgBox "キャンセルされました"
Exit Sub
End If
With Sheets("データ表")
Dim i As Long
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
'If Cells(i, "A").Value = ret Then '全文字列比較（A列だけ）存在？
If InStr(.Cells(i, "A").Value, ret) > 0 Then '一部文字列が含まれるか（A列だけ）存在？
MsgBox i & "行に" & .Cells(i, "A") & "があります"
End If
Next
MsgBox "他に" & ret & "がありません"
End With
End Sub
Findメソッドを使うときは特に LookAtを省略しない方が良いです。
それから、「c.Address」だとセル番地ですよね？ （セル番地が分かれば良いのかもしれませんが。。。）
一寸イメージが良く分からないのですが。。。 父親＝＝＝母親 ｜ ｜子１★ ★子１＝＝＝子１の妻 ｜ ｜ ｜ ｜ ｜子２ ｜
★を繋げば良いのですか？
シートに書き出した状態で検索するなら 性別の記号や「故_」印等が有りますので 部分一致で検索するのが良さそうに思います。
そして、検索値にする場合は それらの不要部分は 削除して検索値にするのが良さそうですね。
親同士が結ばれる事が無いなら、子の方からのみ 攻めていくと無駄もなくなりそうです。
例えば、名前を入力するときのルールとして 名字 名前・・・・・名字と名前の間はスペースを入れる。 名字[旧姓]名前 ・・旧姓は 名字と名前の間の []の中に書く とする。
すると、まずは「名字 名前」で検索。 見つからなかった場合は 「[名字]名前」に変換して もう一度検索。
で、おおよそ見つかるんじゃないかと思います。
イメージだけで話をしているので 実際は色々な問題が出てきて困難な道のりになるかもしれませんが。
(HANA)
ありがとう ございます。 言われるように 婚姻への関係線を書くので １：婚姻の前者になると同じ生年で その行内で検索ですが、２：婚姻の後者では行が異なるので とても大変になりそうです。しかし 今の方向でやってみたい。 以下の途中まで動作するコードで Set c = Selection.FindNext(c)でエラーになります。
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
' 仮の値
xrb = 1 '左端セル行番号
xcb = 2 '左端セル列番号
xre = 3 '右端セル行番号
xce = xcb + 4 '右端セル列番号
' ここは子と一致する親の名前の生年を見つける
For ir = 2 To UBound(tbl1, 1)
If tbl1(ir, 1) <> "" Then
For irg = 2 + 1 To UBound(tbl1, 1)
If InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 And ir <> irg Then
If MsgBox("the same ? " & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 8) - nn + 1 '生年の行番地 西暦変換済み
' ここまでOK 次に生年の行内探索
With Sheets("系譜図").Range("D2").Rows(xrb).Select 'Selection.
Set c = Selection.Find(tbl1(ir, 1), LookIn:=xlValues, LookAt:=xlValues )
If Not c Is Nothing Then
firstAddress = c.Address
Do
MsgBox c.Address & "に" & c.Value & "があります"
' ここまでOK
Set c = Selection.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
MsgBox "他に" & tbl1(ir, 1) & "がありません"
End With
Call KankeiSen(xrb, xcb, xre, xce)
End If 'If MsgBox("the same ?
End If 'If InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
いろいろSelect などを変えてみるのですが 異なるエラーが同じところででます。
はい c.Addressではそのまま使えないのですが、C.Address.columsのような行、列番を 引き出すものはありませんでしょうか
本題とは 外れますが
上のコード
If MsgBox("the same ? " & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
の試行をして 途中でやめたいのですが 現状では リストの最後までFor〜Nextをするか あるいは強制 終了するかないのですが 他の方法はありませんか。前者は時間が、後者はまだコード保存をしていないなど不都合です。
HANAさん
ありがとうございます
＞ 一寸イメージが良く分からないのですが。。。 子が婚姻して 傍系で 筆頭者（＝＝＝の左側記載）になる場合は このとおりです。 もう一つの例は 多くの女性のように 筆頭者でなく＝＝＝の右側記載の場合です この場合が生年と行とが無関係でちょっとむずかしい。 とりあえず、前者の場合を卒業してからにします。
今頃 この課題で質問するのは間違いかもしれませんが この課題でいよいよ これまで不理解のままにしていたツケが効いて ぜひ教えを乞いたいとおもいます
これまでのコードで
With Sheets("データ表")
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 12)
End With
と指定して データを配列にしています。
その後
Private Sub snsr(tbl1, nn, totbl, erf)
で bl1(ij, 7)〜tbl1(ij, 12)までの値を求めていると理解しました。
その結果、その使い方から
'tbl1(ij, 1)名前 tbl1(ij, 2)生元号 tbl1(ij, 3)生年 tbl1(ij, 4)没元号 tbl1(ij, 5)没年 tbl1(ij, 6)関係 は生データ
'tbl1(ij, 7) tbl1(ij, 8)生年 tbl1(ij, 9)没年 tbl1(ij, 10)生元号 tbl1(ij, 11)没元号 tbl1(ij, 12)享年
は新たなデータと理解しました
これで良いでしょうか？
もし 良いとすると生年 没年は西暦換算の数値でしょうか？それとも？
これまでは問題なかったのですが 本題でtbl1(ij, 8)が"" や"?"の場合があって xrb = tbl1(ir, 8) - nn + 1 '生年の行番地 西暦変換済 で 型が一致しないとでます。 不明な場合は最古年（西暦）になっていると理解していたのですが 理解がちがっていました。
snsr() を変えないで 本課題での えらーで止まるのを避けたいです。
現在のコードは
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long, alrdy As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
'リスト内の同一人候補を検出・手動確認しました｡
alrdy = 1 ' 後出とで 2度でるのを避ける
For ir = 2 To UBound(tbl1, 1)
If ir <> alrdy And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If ir <> irg And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then 'tbl1(ir, 1) in tbl1(irg, 1)?
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 8) - nn + 1 '生年の行番地 西暦変換済み
alrdy = irg
'仮設
'xrb= 1 左端セル行番号
xcb = 2 '左端セル列番号
xre = 3 '右端セル行番号
xce = xcb + 4 '右端セル列番号
With Sheets("系譜図").Range("D2").Rows(xrb).Select 'Selection.
Set c = Selection.Find(tbl1(ir, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
MsgBox c.Address & "に" & c.Value & "があります"
Set c = Selection.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
MsgBox "他に" & tbl1(ir, 1) & "がありません"
End With
Call KankeiSen(xrb, xcb, xre, xce)
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
これで同一人の場合該当の行に線の開始で 描くようになりました。 まだ 当該セルには行かない。
ファイルが自宅にしか無かったもので 遅くなってごめんなさい。
＞tbl1(ij, 8)生年 tbl1(ij, 9)没年 tbl1(ij, 10)生元号 tbl1(ij, 11)没元号 tbl1(ij, 12)享年 ＞これで良いでしょうか？
微妙に違うのではないかと思います。 おおよそ 8: 生年 or ？ or "" ←生年が入力されていたら生年(西暦)、?だったら?、未入力で "" 9: 没年 or ？ or "" ←没年が入力されていたら没年(西暦)、?だったら?、未入力で "" 10: 生年月日（B列 & C列) 11: 没年月日（D列 & E列） 12: 享年フラグ の様なデータが作成されています。 もう忘れてしまっているので、実際は少し違うかも知れませんが。。。
?や""だったときに、どの行で検索しますか？ 例え ＞不明な場合は最古年（西暦）になっていると理解していたのですが 最古年が入っていて、エラーに成らずに処理が進んだとしても それでは検索出来たことには成りませんね。 「実は、生年が分かっていたけど 片方のデータを入力する際は 分からないと思って入力していなかった」 「後から生年が発覚したが、片方しか更新しなかった」 なんてパターンは、あり得ると思いますよ。
＞しかし 今の方向でやってみたい。 は、ご自由ですが コードにする前に、 データが揃っていない時 や 単純に行が特定できない時 等に どの様に処理をするのかは考えておく必要が有ると思います。
現在は、処理方法を思いついた所（一番簡単な所）から コードを書こうとして居られるように感じますが 寧ろ、その 難しい処理が 本当にその考え方で出来るのかどうか 検証していくところから始めるのが良いと思います。 勿論、難しくない所の処理も 同じ処理で出来るのかは 見据えながら考えていく必要が有ると思いますが。
せっかくコードを作成しても 「全部データが揃ってたら上手いこと行くんだけど そうでないときに 矢っ張り上手く行かないから このコードは使えないな」 なんて結論が出た場合に コードの作成に費やした時間が無駄に成ります。
ちなみに、同じコード内で使用するので有れば、 tbl1の範囲をもう少し増やして どの行のどの列に名前が入ったか 決まった時点で記録しておくと良いかもしれません。
tbl1の行と、データ表シートの行は一致するので データ表シートのA列内で検索し tbl1の新しく増やした列を見に行けば どの行のどの列に名前が入っているか 簡単に分かるように成りそうに思います。 （名字が変わっていない場合は、完全一致で探せる様に成ります。）
また、もしも 生年月日の一致確認もしようと思われた場合でも tbl1の10列目を見ることで簡単に出来そうに思います。
前のコードは最終的に
＞.Range("D1").Resize(UBound(y, 1), xc + 3) = x
で、系譜図シートのD1セルを先頭に xに入っているデータを書き出しました。
一つ新しくシートを用意して、同じ様に tbl1の内容も書き出して、実際に目で見て確認して行くと イメージが作りやすいかも知れません。
(HANA)
ありがとうございました
おっしゃるとおり
養子とか 婚姻筆頭者等の同じ行内の重複記載なら 本件表題のような操作でいけると踏んで
まず これを解決してからと思ったのですが
実際には 手で線を書いている事例では 婚姻相手で異なる行のセル間の線引きです。
そこで 思い切って
'tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 12)
の代わりに
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 14) 'セル位置を記録 用に増やす
tbl1(ij,13)は行番、tbl1(ij,14)は列番を記録する。
両親表示の xr = tbl1(ij, 8) - nn + 1 '2代以後親生年の行番地 あるいは xr = psn(nn, p1(2), p2(2)) - nn + 1 '1代子・親生年の行番地
Call Marriage(p1, p2, x, xr, xc, keifu) '2代以後親の書込み tbl1(ij, 13) = xr '婚姻のセルの行番 tbl1(ij, 14) = xc + 2 '婚姻相手のセルの列番
と記録コードを追加しました。
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long, alrdy As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
'仮数値
xrb = 1 '左端セル行番号
xcb = 2 '左端セル列番号
xre = 3 '右端セル行番号
xce = xcb + 4 '右端セル列番号
'リスト内の同一人候補を検出・手動確認しました｡
alrdy = 1 ' 後出とで 2度でるのを避ける
For ir = 2 To UBound(tbl1, 1)
If ir <> alrdy And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If ir <> irg And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then 'tbl1(ir, 1) in tbl1(irg, 1)?
'If InStr(Sheets("データ表").Cells(i, "A").Value, tbl1(ir, 1)) > 0 Then
alrdy = irg
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 8) - nn + 1 '生年の行番地 西暦変換済み
xrb = tbl1(ir, 13)
xcb = tbl1(ir, 14)
Call KankeiSen(xrb, xcb, xre, xce)
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
しかし 現在は tbl1(ij, 13) tbl1(ir, 14)がうまく 値が入っていなく、Empty値です。 どこが おかしいか ”眺めて”いる事態です
＞tbl1(ij, 13) tbl1(ir, 14)がうまく 値が入っていなく、Empty値です。 tbl1(ij, 13) tbl1(ir, 14)に値を入れる処理が全て終わっても この部分に値が入っていないって事ですか？
でしたら ＞Private Sub DoituNin(tbl1, nn) のコードを作る以前の問題に思いますが？
前の段階がクリアできていないのに 次の段階のコードが出来ていることに疑問を感じます。
それとも、書いて居られる文章が tbl1(ij, 13) tbl1(ir, 14)【から】うまく 値が入っていなく （＝ xrb, xcbに、tbl1(ij, 13) tbl1(ir, 14)の値が入らない） の書き間違えでしょうか？
そうそう、どこかで書いたかも知れませんが コメント記入の際は、ご署名をお忘れなく。
(HANA)
ありがとうございます。
今ごろになって 質問ですが、Sheets("データ表")で次のようにしています。
With Sheets("データ表")
'tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 12) -->
'セル位置記録用を増すために
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 14)
'tbl1(ij, 1)名前 tbl1(ij, 2)生元号 tbl1(ij, 3)生年 tbl1(ij, 4)没元号 tbl1(ij, 5)没年 tbl1(ij, 6)関係
' 8:生年(西暦) or ？ or 未入力で""、9: 没年(西暦) or or ？ or 未入力で""
'10:生年月日 (B列 & C列) 11:没年月日 (D列 & E列) 12:享年フラグ
End With
ここでデータ表A-F（１〜６)までは入力データとして記入していますが、Gから右欄はメモ代わりに使っています。 このことと tbl1(ij, 8)〜tbl1(ij, 14)を操作用メモリとして用いることと 無関係でしょうか？
メモに記載した文字 数字など が tbl1(ij, 8)〜tbl1(ij, 14)に現れないし、その逆もないのですが
どうして 区別しているのでしょうか？
tbl1(ij, 13)、tbl1(ij, 14)をMsgで書き出すと あるときはデータ表の数値で 他は
別の数値ができますが後者はどこからの数値か不明です。
（はんにゃ）
＞tbl1(ij, 13)、tbl1(ij, 14)をMsgで書き出すと こんな事でちまちま確認するのではなく
＞＞一つ新しくシートを用意して、同じ様に ＞＞tbl1の内容も書き出して 確認して下さい。
ちなみに区別はしていません。 元々入力されていた情報は、残っていないはずです。 どこかに tbl1(○,8〜14のいずれか) = "" と言う部分が入っています。 残っているなら、コードがどこかで間違っています。
tbl1の右側を使うと、確認するために書き出す場合 簡単だと思ったのでその様にしましたが その事が混乱を招いたり、不安に思われたりするなら もう一つ新しい変数を用意して それを使用して下されば良いと思います。
(HANA)
ありがとうございます
＞＞一つ新しくシートを用意して、同じ様にtbl1の内容も書き出して
今になって わかりました。 はい やってみます。
（はんにゃ）
HANAさん はじめ 助言を下さった方がた ありがとうございました。
まだ 関係線の位置が不満足ですが 出来ましたので http://www.mediafire.com/download.php?mgxgtizl2dt の載せてあります。 これを実行すると MｓｇBoxがでます。OKをすると同一人確認でその関係線引きをします。 ありがとうございました。
HANAさん tbl1の各配列を見ました。 （ｙ、７）の備考はそのまま、記載 ８）、９）、１０）、１１）は正常 １２）の享年Index は生年、没年 いずれかに 空欄、 ？、 不明等がある場合に１となる。 これは 現在どんな役割をしていますか？ もちろん 系譜図作図には現状でも問題ないです 系譜組の間の氏名データなどがなくて 空欄のときも１となる。 １３）１４）は正常のようです。
自分の事は割と簡単に書けるので こちらから先に載せておきます。
＞ １２）の享年Index は生年、没年 いずれかに 空欄、 ？、 不明等がある場合に１となる。 ＞ これは 現在どんな役割をしていますか？ えっと・・・かなりテキトウに作ったので つっこまれると困るのですが。。。（笑）
載せて居られるコードだと
Private Sub Kakikomi(tbl1, ij, x, xr, xc) '系譜線上の息子、娘らの書込み
の中の
x(xr - 1, xc + 2) = sngpse(tbl1(ij, 8), tbl1(ij, 9), tbl1(ij, 10), tbl1(ij, 11), tbl1(ij, 12))
'系譜線の生年の1行上に生年、没年 享年等を書き込む
に出てきますね。「tbl1(ij, 12)」
そこで、sngpseを見ると Private Function sngpse(ss, se, tngp, bngp, nr) '生年、没年 nr享年 nr が、tbl1(ij,12) にあたります。
コード内で、nrが出てくるのは
If nr = Empty And se <> Empty And ss <> Empty Then
sngpse = sngpse & "享年" & se - ss + 1
ElseIf bngp <> "" Then
sngpse = sngpse & "享年？"
End If
ここです。
変数名は いつもテキトウにつけて あまり一貫性が無いので 元の言葉を書くのは憚られるのですが ssは誕生年（ＳeirekiでＳtartの年） seは没年（ＳeirekiでＥndの年） tngpは、誕生年月日（ＴanjyouＮenＧaＰpi） bngpは、没年月日（ＢotsuＮenＧaＰpi） って感じにしたんだと思います。
＞生年、没年 いずれかに 空欄、 ？、 不明等がある場合に１となる。 この場合は、享年が計算出来ませんのでフラグを立てようと考えて作成しました。 本来は、フラグが立っていない時は 没年計算をすればよいので 「And se <> Empty And ss <> Empty」の条件は 不要なのかもしれません。
しかし詳細に見ると ＞系譜組の間の氏名データなどがなくて 空欄のときも１となる。 この部分が問題で上手く行かないのかもしれません。
或いは他に何か問題が有るかもしれません。
試行中に上手く行かなかったので足したのですが 現在どうなるのかはよく分かりませんので そちらで検証して、しかるべき様に修正して頂ければと思います。
(HANA)
HANAさん ＞ tbl1(x,12)の享年Indexは 生年、没年いずれかに空欄、？、不明等がある場合に１となる。 の件 了解しました。ありがとうございました。 とりあえず このままにしておきます。これが悪さをするとは考えられないので。
関係線は tbl1(x,13 or 14)の初期値１，２以上の条件で 今のところ進めて かなり目的を達しつつあります。 該当セルが当該者の婚姻の相手になっていたりしての問題で ちまちま攻めているところです。 やってみます。
(はんにゃ）
現在、このスレでの質問部分のコードに関して 上手く動いているように思われますが もう少し色々なパターンが増えて来て
例えば、3行目と10行目に一つ組合せがある時に その間にさらに組合せ（の片方でも）有ると 重複検索しない為につけて居られるフラグは 用をなさなくなると思います。
私なら、tbl1にもう一列増やして 一致確認がされたときに 二箇所にフラグをたてます。
検索するときも、そのフラグの有無を先に確認し 無い場合に検索する事にすると無駄もなくなると思います。
なお ＞tbl1(ij, 13)、tbl1(ij, 14)をMsgで書き出すと と言う表現で、少し気になっているのですが。。。 ローカルウィンドウは表示して居られますか？
出すと画面が狭くなってしまうんですけどね。。。 変数の値等が確認出来ますし （勿論 tbl1の内容に関しても） ステップインで実行時に 刻々と変化していってくれるので それらのデータを見ながら、確認して行くと良いかもしれません。
(HANA)
おせわになりました。 一応 この http://www.mediafire.com/download.php?zjyn2zwlglw に仕上がりましたので お礼を兼ねて報告します ご多忙ですが 見ていただければ幸甚です。
HANAさんのご指摘を読む前に 作業をしたので 返答は この後調べていたします
>その間にさらに組合せ（の片方でも）有る とは
2 長女 1779.2 娘 3 始 1760.1 父 4 始の妻 1764.1 母 5 長男 1780.1 息子 6 次男 1781.1 息子 7 四男 1787.3 息子 8 三男 1785.1 子親 9 [他家」嫁 1788.1 母 10 長女２ 1798.1 娘 11 長男２ 1800.1 息子親 12 [他家２」嫁 1810.1 母 13 長男3 1817.1 息子 14 長女3 1815.1 娘親 15 [他家3」養子 1810.1 父 16 長女4 1825.1 娘
を元に指摘されておられると推測して この ５，６，７のいぞれかに この直系とは別に独立系譜組みが有る場合 を指されておられると思います。直系では同名であっても 誕生日もあわせたので排除されます。独立系でも同じですが、念のために 同一人かどうかの確認は手動の確認反応でいたしています。 それで ご指摘が どのような問題点かわからないでいます。
同一人の検索の仕方の良策を言われておられるようですが 今すぐにどういうことか 理解不足です。
＞tbl1(ij, 13)、tbl1(ij, 14)をMsgで書き出すと はい 助言のようにSheetに全部書き、検査に活用しました。 セル自体のアドレスと内容などはMegで出しました。小さなMegboxです。 現コードはこれはコメント化してあります。
これで答えになっているでしょうか
(はんにゃ）
言われたことは 上のあとに出てくる直系の子 智が独立系譜を成す
△智 ｜ △智= X =▼[當]千
の場合でしょうか これも生年と合わせて一箇所しか関係該当の確認問い合わせがでません。
(はんにゃ
そちらで仰る「直系」と言うのがどういう物か 良く分かっていませんので、私が思っているような データ状況には成らないのかも知れません。
コードの内容から言うと、例えば３つの家族があって １つ目の家族の中で ５行目に Aさん ６行目に Bさん ２つ目の家族の中で ８行目に Aさん ３つ目の家族の中で 12行目に Bさん と成っていた場合 2回メッセージボックスが出れば良いですが 4回出ますね。
データとして名前しか挙げていませんが 生年月日まで一致している場合で 確認してみて頂ければと思います。
一つの家族の中から 複数人が出て行ったり 見つかったデータの行へ行くまでの間に 別の人で組合せが見つかったりする事が 有るんじゃないかと思いますが。。。 私の考え違いであれば 忘れて下さい。 そろそろ本格的に どの様な状況が有ったり どうなれば良いのか分からなくなってきてる様です。
(HANA)
検証ありがとうございます。 事例は次の如くと理解しました。
長女 1779.2 娘 家族甲 始 1760.1 父 始の妻 1764.1 母 長男 1780.1 息子 A 1781.1 息子 B 1787.3 息子
家族乙 A 1781.1 父 [他家」嫁 1788.1 母 長女２ 1798.1 娘
家族丙B 1787.3 父 [他家２」嫁 1810.1 母 長男3 1817.1 息子 長女3 1815.1 娘親 [他家3」養子 1810.1 父 長女4 1825.1 娘
これを実行すると AさんとBさんについて確認は2回しかでません。 はい、出現同士相互に確認すると 同じ氏名、生年同一でも2回、 事例では計４回になるのを避けるために 次のように既出Index alrdy を設けています。
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long, alrdy As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
Dim nam As Long
'xrb = 1 '左端セル行番号
'xcb = 2 '左端セル列番号
'xre = 3 '右端セル行番号
'xce = xcb + 4 '右端セル列番号
' 既定値 tbl1(ij, 13) = 1: tbl1(ij, 14) = 2
'For ir = 2 To UBound(tbl1, 1)
' If tbl1(ir, 13) > 1 Or tbl1(ir, 14) > 2 Then
' If MsgBox(ir & tbl1(ir, 1) & " -> " & Sheets("系譜図").Range("D2").Cells(tbl1(ir, 13), tbl1(ir, 14)), vbYesNo) = vbYes Then
' Else: Exit For
' End If
' End If
'Next 'For ir = 2
'リスト内の同一人候補を検出・手動確認しました｡
alrdy = 1 ' 後出とで 2度でるのを避ける
For ir = 2 To UBound(tbl1, 1)
If ir <> alrdy And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If ir <> irg And tbl1(irg, 10) = tbl1(ir, 10) And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then
'If ir <> irg And InStr(Split(tbl1(irg, 1), "「"), tbl1(ir, 1)) > 0 Then
'tbl1(ir, 1) in tbl1(irg, 1)?
'If InStr(Sheets("データ表").Cells(i, "A").Value, tbl1(ir, 1)) > 0 Then
alrdy = irg
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
xre = tbl1(irg, 13) '= tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
xce = tbl1(irg, 14) '
'MsgBox xrb & "行" & xcb & "列セルから" & xre & "行" & xce & "列セルから線引き"
Call KankeiSen(xrb, xcb, xre, xce)
Else: Exit For
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
直系というのは 事例で13行目の長女3は家族丙の娘でもあり、次の世代の母親でもあり、 独立した系譜図を持たない場合には同じ人をデータ入力で2度書きしないもよいような関係を指します。 こうすれば 上の家族甲から乙、丙いずれかは書かなければなりませんが、 家族乙、家族丙分の２つ書 かなくてもすみます。 この直系という意味は一般に言う戸主とか家系の継承者の意味ではなく、 単なる繋がり（下の世代のある人から 上の世代を辿る）と考えてください。 結果は
｜ ｜ 1810.1〜
△B ｜ △家族丙B= X =▼[他家２」嫁
1787.3〜 ｜ 1787.3〜 ｜ ｜
と独立系譜の場合はBが二回書かれて 後で関係線を入れることになる。 それに対して、直系系譜では
1810.1〜 △家族丙B= X =▼[他家２」嫁 1787.3〜 ｜ ｜ ｜ ｜ ｜ ｜ ｜ ｜ ｜ 2 1810.1〜 ▼長女3= X =△[他家3」養子 ｜ 1815.1〜 △長男3 ｜ 1817.1〜 ｜ ｜ ｜ ｜ ｜ ｜ ｜ ▼長女4 1825.1〜
（はんにゃ） 法外の望みですが 貴殿もこれをご活用頂ければ幸甚です。
AとBは息子なので 同じ名前が出現するのかと思いましたが ↓の感じ [A] [B] [C] [D] [E] [F] [1] [2] 長女 1779.2 娘 [3] 家族甲始 1760.1 父 [4] 始の妻 1764.1 母 [5] 長男 1780.1 息子 [6] A 1781.1 息子 [7] B 1787.3 息子 [8] [9] A 1781.1 父 [10] [他]嫁 1788.1 母 [11] 長女２ 1798.1 娘 [12] [13] B 1787.3 父 [14] [他2]嫁 1810.1 母 [15] 長男3 1817.1 息子 [16] 長女3 1815.1 娘親 [17] [他3]養子 1810.1 父 [18] 長女4 1825.1 娘
片方は 名前だけ 片方は 名字+名前 と入力されるのですね？
でしたら、名字+名前 での調査時に 名前 の行は ヒットしないので 大丈夫ですね。
alrdyは 見つかった行へ行くまでの間に 次のデータが見つからない場合に For irg = 2 + 1 To UBound(tbl1, 1) のループ処理が省略出来る と言う働きをしていて 無くてもメッセージボックスは ２回しか表示されないと思います。
(HANA)
意図通りでないのでもっと考えます。 ＞ 見つかった行へ行くまでの間に 次のデータが見つからない場合に For irg = 2 + 1 To UBound(tbl1, 1) のループ処理が省略出来る ＞ は なにかに役にたっているとしても 違う働きです。 ご指摘ありがとうございました。 上の＞次のデータが見つからない場合に と言う意味が 理解不足です 検討します。
その後 子が独立系譜になった場合、子としてのセルと 独立系譜の婚姻セルで2度かかれます。 手操作で 後者セル内容を消していたのですが、自動化しました。
△智= = ============= X =▼[當]千 ｜ 昭和47.12.19〜
（はんにゃ）
Private Sub KankeiSen(xrb, xcb, xre, xce) Dim sbs As String Dim irj As Long, irb As Long, ire As Long Dim xrf As Long, xcf As Long '臨時代替
Dim dblBeginX As Double, dblBeginY As Double, dblEndX As Double, dblEndY As Double
'MsgBox Cells(xrb, xcb).Address & "から" & Cells(xre, xce).Address & "に線を描く"
'MsgBox Sheets("系譜図").Range("D2").Cells(xrb, xcb) & "から" & Sheets("系譜図").Range("D2").Cells(xre, xce) & "に線を描く"
sbs = "▼"
If xrb = xre Then '同じ生年での婚姻関係線
With Sheets("系譜図")
.Range("D2").Cells(xrb, xcb) = .Range("D2").Cells(xre, xce)
.Range("D2").Cells(xrb, xcb + 1) = "" ' 名前の幅内
.Range("D2").Cells(xrb, xcb + 2) = "" ' 名前の幅内
.Range("D2").Cells(xrb + 1, xcb + 2) = "" ' 生年の幅内
.Range("D2").Cells(xre, xce) = "" ' 婚姻重複削除
.Range("D2").Cells(xre + 1, xce) = "" ' 生年姻重複削除
For irj = xcb + 3 To xce
If .Range("D2").Cells(xrb, irj) = "" Then
.Range("D2").Cells(xrb, irj) = "'="
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), sbs) > 0 Then
Sheets("系譜図").Range("D2").Cells(xrb, irj).Font.color = RGB(255, 0, 0)
Else
Sheets("系譜図").Range("D2").Cells(xrb, irj).Font.color = RGB(0, 0, 255)
End If
End If
Next
End With
ElseIf xcb < xce Then
With Sheets("系譜図").Range("D2").Cells(xrb, xcb)
' dblBeginX = .Left + .Width / 2
dblBeginX = .Left + Len(Sheets("系譜図").Range("D2").Cells(xrb, xcb)) * 10 'dblBeginX = .Left + .Width / 2
dblBeginY = .Top + .Height / 2
End With
With Sheets("系譜図").Range("D2").Cells(xre, xce)
dblEndX = .Left
dblEndY = .Top + .Height / 2
End With
With Sheets("系譜図").Shapes.AddLine(dblBeginX, dblBeginY, dblEndX, dblEndY).Line
.DashStyle = msoLineDash
.Weight = 1.5
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), sbs) > 0 Then
.ForeColor.RGB = RGB(255, 0, 0)
Else
.ForeColor.RGB = RGB(0, 0, 255)
End If
End With
Else
With Sheets("系譜図").Range("D2").Cells(xre, xce)
' dblBeginX = .Left + .Width / 2
dblBeginX = .Left + Len(Sheets("系譜図").Range("D2").Cells(xre, xce)) * 10
dblBeginY = .Top + .Height / 2
End With
With Sheets("系譜図").Range("D2").Cells(xrb, xcb)
dblEndX = .Left
dblEndY = .Top + .Height / 2
End With
With Sheets("系譜図").Shapes.AddLine(dblBeginX, dblBeginY, dblEndX, dblEndY).Line
.DashStyle = msoLineDash
.Weight = 1.5
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), sbs) > 0 Then
.ForeColor.RGB = RGB(255, 0, 0)
Else
.ForeColor.RGB = RGB(0, 0, 255)
End If
End With
End If
End Sub
さっそく 既出で再確認を避けるため 見直して
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long, alrdy As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
Dim nam As Long
'xrb = 1 '左端セル行番号
'xcb = 2 '左端セル列番号
'xre = 3 '右端セル行番号
'xce = xcb + 4 '右端セル列番号
'リスト内の同一人候補を検出・手動確認しました｡
alrdy = 1 ' 既出の再確認を避ける
For ir = 2 To UBound(tbl1, 1)
If ir <> alrdy And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If irg <> ir And tbl1(irg, 10) = tbl1(ir, 10) And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then
'If ir <> irg And InStr(Split(tbl1(irg, 1), "「"), tbl1(ir, 1)) > 0 Then
'tbl1(ir, 1) in tbl1(irg, 1)?
'If InStr(Sheets("データ表").Cells(i, "A").Value, tbl1(ir, 1)) > 0 Then
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
alrdy = irg
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
xre = tbl1(irg, 13) '= tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
xce = tbl1(irg, 14) '
'MsgBox xrb & "行" & xcb & "列セルから" & xre & "行" & xce & "列セルから線引き"
Call KankeiSen(xrb, xcb, xre, xce)
Else:
alrdy = irg
Exit For
End If 'If MsgBox("the same ?
alrdy = irg
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
alrdy = irgを入れるコード位置を変え、増やしました。 これでA,A あるいはB.Bの再確認がなくなりました。
再度 http://www.mediafire.com/download.php?qndwzgku2om に載せましたので つかってください。（はんにゃ）
先の
Private Sub KankeiSen(xrb, xcb, xre, xce)の一部を修正し婚姻関係線=======をきれいに引くようにしました
If xrb = xre Then '同じ生年での婚姻関係線を引く
With Sheets("系譜図")
.Range("D2").Cells(xrb, xcb) = .Range("D2").Cells(xrb, xcb) + "=" '.Range("D2").Cells(xre, xce)
.Range("D2").Cells(xrb, xcb).Font.Bold = True
.Range("D2").Cells(xrb, xcb + 1) = "" ' 名前の幅内
.Range("D2").Cells(xrb, xcb + 2) = "" ' 名前の幅内
.Range("D2").Cells(xrb + 1, xcb + 2) = "" ' 生年の幅内
.Range("D2").Cells(xre, xce) = "'==============" ' 婚姻重複名前削除
.Range("D2").Cells(xre, xce).Font.Bold = True
If InStr(.Range("D2").Cells(xrb, xcb), sbs) > 0 Then
.Range("D2").Cells(xre, xce).Font.color = RGB(255, 0, 0)
Else
.Range("D2").Cells(xre, xce).Font.color = RGB(0, 0, 255)
End If
.Range("D2").Cells(xre + 1, xce) = "" ' 婚姻重複生年削除
For irj = xcb + 2 To xce - 1 ' "'=============="
If .Range("D2").Cells(xrb, irj) = "" Then
.Range("D2").Cells(xrb, irj) = "="
.Range("D2").Cells(xrb, irj).Font.Bold = True 'Sheets("系譜図").
If InStr(.Range("D2").Cells(xrb, xcb), sbs) > 0 Then
.Range("D2").Cells(xrb, irj).Font.color = RGB(255, 0, 0)
Else
.Range("D2").Cells(xrb, irj).Font.color = RGB(0, 0, 255)
End If
End If
Next
End With
ElseIf xcb < xce Then
以後 変更なし
略
（はんにゃ）
＞上の ＞＞次のデータが見つからない場合に ＞と言う意味が 理解不足です
ごくごく小さなサンプルで 最初に載せて居られたコードの流れを考えてみます。
A2セルから行方向へ A,A,B,Bとデータが入っていた場合
A2セルの A を検索値として alrdy<>2なので、ループ処理開始 A2セルは自セルなので調査しない A3セルを調査して 同じ値なので alrdyに「3」を書き込む ループ処理を抜ける A3セルの A を検索値として alrdy=3なので、ループ処理せず終了 A4セルの B を検索値として alrdy<>4なので、ループ処理開始 A2セルは一致しない A3セルは一致しない A4セルは自セルなので調査しない A5セルが一致 alrdyに「5」を書き込む ループ処理を抜ける A5セルの B を検索値として alrdy=5なので、ループ処理せず終了
A3,A5セルはループ処理をせず終了しているので 良さそうです。
では A2セルから行方向へ A,B,A,Bとデータが入っていた場合 を考えてみると A2セルの A を検索値として alrdy<>2なので、ループ処理開始 ： A4セルが一致して alrdyに「4」を書き込む A3セルの B を検索値として alrdy<>3なので、ループ処理開始 ： A5セルが一致して alrdyに「5」を書き込む A4セルの A を検索値として alrdy<>4なので、ループ処理開始 ： A2セルが一致して alrdyに「2」を書き込む A5セルの B を検索値として alrdy<>5なので、ループ処理開始 ：
と成りますから、alrdyが はんにゃさんの意図した働きをしていません。
＞alrdy = irgを入れるコード位置を変え、増やしました。 ＞これでA,A あるいはB.Bの再確認がなくなりました。 と言う事ですので、確かに再認識は無いのかもしれませんが 私は、変数一つで処理できないのではないかと思っています。
つまり、今回も「上手く行っているように思える」 と言う状況ではないかと思います。
どこをどの様に変更されたのか分かりませんので 少し場所をとってしまいますが 小さなサンプルにして、コードも主要部分のみ抜き出して 流れを上の様に順番に書いてみてもらえませんか？
私が「駄目なんじゃないか」と思っているだけで 実際は大丈夫なのかもしれません。
(HANA)
ありがとうございます たしかに 同一人の行順で 出現順が 指摘のA,B,A,Bとなると Aの対応行で alrdy = irgが記録されてしまい、次のBの対応行とならないで 期待の働きをしません。 実際に動かしても 2回確認問いが出ます。 このようにしっかり検証しなかった。
すると言われるように 各行毎の対応既出のIndexが必要か？ もう一度調べます （はんにゃ）
Private Sub DoituNin(tbl1, nn)
Dim ir As Long, irg As Long
Dim msgres As VbMsgBoxResult
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
'xrb = 1 '左端セル行番号
'xcb = 2 '左端セル列番号
'xre = 3 '右端セル行番号
'xce = 4 '右端セル列番号
' 既定値
For ir = 2 To UBound(tbl1, 1)
tbl1(ir, 7) = 1
Next 'For ir = 2
'リスト内の同一人候補を検出・手動確認しました｡
'tbl1(ij, 7)DoituNin検索のIndes ' 既出の再確認を避ける
For ir = 2 To UBound(tbl1, 1)
If tbl1(ir, 7) = 1 And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If tbl1(irg, 7) = 1 And irg <> ir And tbl1(irg, 10) = tbl1(ir, 10) And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then
tbl1(irg, 7) = 2: tbl1(ir, 7) = 2
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
xre = tbl1(irg, 13) '= tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
xce = tbl1(irg, 14) '
'MsgBox xrb & "行" & xcb & "列セルから" & xre & "行" & xce & "列セルから線引き"
Call KankeiSen(xrb, xcb, xre, xce)
Else:
Exit For
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
以上のように やはりTbl1の空きの7列目を使うことにしました。これで再確認は避けられた。 なぜか 初期値０ではうまくいかず、１として 確認済みは２としました。 これは 確認はある行は他の行間で確認済みで 3つ以上の行間で対応はないという前提です。 要注意。名前の一部が共通でかつ生年の不明は含め同一であると 同一と見なす。
また
For ir = 2 To UBound(tbl1, 1)
If tbl1(ir, 7) <> ir And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If tbl1(irg, 7) <> irg And irg <> ir And tbl1(irg, 10) = tbl1(ir, 10) And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then
'If ir <> irg And InStr(Split(tbl1(irg, 1), "「"), tbl1(ir, 1)) > 0 Then
tbl1(irg, 7) = ir: tbl1(ir, 7) = irg
としてみたのですが なぜか 再確認をしてしまいます。
上側のコードに関して。。。
＞Tbl1の空きの7列目を使うことにしました。 たまたま空いているからと言って 無計画に使わない様に。
このコードの関連は 既に13,14に有るのですから そちらにかためて於いた方が良いと思います。
それから 二つのセルが同じ人だと認められた時に 次回から調査せずに済むようにフラグを付けるのでしたら ＞tbl1(irg, 7) = 2: tbl1(ir, 7) = 2 の入っている位置が おかしいと思いますが
＞3つ以上の行間で対応はないという前提です。 確認の結果が、Yes でも No でも その行はもう検索しなくて良い って事ですか？
＞なぜか 初期値０ではうまくいかず、１として 確認済みは２としました。 tbl1の中身を確認しながら 実行しましたか？
上手く行かなかったのは、何か理由が有るはずです。 上で載せられたコードから、該当の1,2のみを 0,1に変更して 再度やってみられてはどうでしょう。
下側のコードに関しては。。。
コードにする前に 考えてみてください。 「エクセルに実行させて 上手く動いた様に見えて ＯＫ」 とするのではなく、 先に簡単なデータを作成（想定）して 自分でコードを実行しながら 各変数に値を入れて行き 本当にそれで良いのか検証です。
＞流れを上の様に順番に書いてみてもらえませんか？ と書きましたよね。 書いてみられたらどうですか？
(HANA)
With Sheets("データ表")
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 14) 'セル位置記録用を増す
End With
Private Sub DoituNin(tbl1, nn)
Dim msgres As VbMsgBoxResult
Dim ir As Long, irg As Long
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
For ir = 2 To UBound(tbl1, 1)
tbl1(ir, 15) = 1
Next
'リスト内の同一人候補を検出・手動確認
For ir = 2 To UBound(tbl1, 1)
If tbl1(tbl1(ir, 15), 15) <> ir And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If irg <> ir And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 And tbl1(irg, 10) = tbl1(ir, 10) Then
tbl1(irg, 15) = ir: tbl1(ir, 15) = irg
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
xre = tbl1(irg, 13) '= tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
xce = tbl1(irg, 14) '
Call KankeiSen(xrb, xcb, xre, xce) 'MsgBox xrb & "行" & xcb & "列セルから" & xre & "行" & xce & "列セルから線引き"
Exit For
Else:
Exit For
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
と直しました。 対応する氏名の行番をそれぞれの行番のIndex tbl1(irg, 15) tbl1(ir, 15)に記録し、 その数値で既出か否かを判断します。 一度その判断（答えがYesNoいずれでも）をした対の行は 再度しないことにします。 初期値がEmptyでは判断するとき、数値とEmptyでは比較不能となるので 初期値に数値を入れておかないいけない（無害な１とした）
A2セルから行方向へ下表の如く6行-A,7-B,9-A,13-Bとデータが入っていた場合
A6セルの A を検索値として 初期値１しかはいっていないので
tbl1(tbl1(ir, 15), 15) <> ir #すなわち 1<>6 なので、irループ処理開始
irgループで
A6セルは自セルなので調査しない
A9セルを調査して 同じ値なので
Indexとして 互いの行番を書き込む
tbl1(6, 15)=9 tbl1(9, 15)=6
irgループ処理を抜ける
irループ処理終わり
A7セルの B を検索値として 上記と同様で
tbl1(7, 15)=13 tbl1(13, 15)=7
irループ終了。
A9セルの A を検索値として
tbl1(tbl1(ir, 15), 15) <> ir
#すなわち 9<>9 なので、irループ処理せず終了
A13セルのBを検索値として
tbl1(tbl1(ir, 15), 15) <> ir
#すなわち 13<>13 なので、irループ処理せず終了
一方 A2セルから行方向へ6行-A,7-B,9-B,13-Aとデータが入っていた場合 A6セルの A を検索値として 上述のようにして tbl1(6, 15)=13 tbl1(13, 15)=6 irループ終了。 A7セルの B を検索値として 上述のようにして tbl1(7, 15)=9 tbl1(9, 15)=7 irループ終了。 A9セルの B を検索値として tbl1(tbl1(ir, 15), 15) <> ir #すなわち 9<>9 なので、irループ処理せず終了 A13セルの A を検索値として #すなわち 13<>13 なので、irループ処理せず終了
と成ります
[A] [N=15] [1] [2] 長女 1 [3] 家族甲始 1 [4] 始の妻 1 [5] 長男 1 [6] A 9 [7] B 13 [8] 1 [9] A 6 [10] [他]嫁 1 [11] 長女2 1 [12] 1 [13] B 7 [14] [他2]嫁 1 [15] 長男3 1 [16] 1 ここで生年が同じなのはAとBのみである。
言い訳です。うまく（甘くの字に合う）いくか どうか面倒になると えい！やってみようとなってしまう
悪い癖が出ます。こころして気をつけます。 （はんにゃ） 旧来の形式 http://life.oricon.co.jp/61031/full/など より 時代の中に視覚的に位置させることができる。
＞面倒になると えい！やってみようとなってしまう 商売でやっている訳ではないので それでも良いと思います。 簡単な段階で確認をしておけば 全てができあがってから 「あ〜、これじゃ 駄目じゃん」なんて事が 少なくなる場合が多いってだけなので。
ただ、上手く行かなかった時に 「○○に成っているハズだから、こう動くハズ」ではなく （実際は、そう動いていないのですから） どこの段階で「ハズ」と実際が異なってきているのか 色々な方法で 一つずつ試していく必要が有ると思いますよ。
ここへ書き込むと、誰かが修正して載せてくれるかもしれません。 しかし、その人がどの様にしてそれを見つけたのか分からなければ いつまでたっても、ご自身で作成したコードをご自身で修正が 出来ないことになってしまいます。
見つける方法 なんて、一つずつ確認して行くしか無いんですけどね。 最初に載せられたコードでも If tbl1(irg, 7) <> irg And irg <> ir And tbl1(irg, 10) = tbl1(ir, 10) And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 Then の「tbl1(irg, 7) <> irg」この部分に注意して、tbl1(irg, 7)の値を追って居れば 「あれ？tbl1(irg, 7)に思った値が入ってないんだけど？ いや、tbl1(irg, 7)は対応する行番号が入っているからあってるよね。 確認するのがtbl1(irg, 7)とは違う所なんだ。じゃあ、どこに有るんだ・・・？」 って、気づけたかもしれません。 コード実行中（ストップ中）に、変数の上にマウスポインタを近づけると その中に入っているものが確認出来るのはご存じですよね？
内容に付いては どこまで想定して居られるのか分かりませんので （思いついた方法を コードにして 動きを確認されているだけ？） なかなか難しいですが、tbl1(irg, 15)が 1以外だったら その時点で「チェック済み」と判断しても 良さそうに思います。
tbl1(tbl1(ir, 15), 15) で、相手の行の情報を 簡単に取得出来るという事が確認できたので 自信を持って、【その様な事が必要な時に】 使用することにすれば良いのではないかと思います。
現在のコードで わざわざ 相手の行のデータを見に行って 今回調査している行と一致するかどうかを確認して 漸く「チェック済みだった」と判断する 必要は無いんじゃないかと。。。。 そこまでしなくても チェック済みかどうかは判定出来るのですから。
＞初期値がEmptyでは判断するとき、数値とEmptyでは比較不能となるので ＞初期値に数値を入れておかないいけない（無害な１とした） この部分がどういった事かよく分かりません。 例えば、変数xが Empty で 変数 r が1の時 「x = r と言った判定が出来ない（エラーになる）」 と言う事ですか？ それとも【比較】と表現して居られるので【判定】とは違う と言う事でしょうか？ その場合、どの様な比較をしようと考えて どの様なコードを書き、どの様に駄目だったのでしょう？
(HANA)
ありがとうございます 貴重な助言 心します
>コード実行中（ストップ中）に、変数の上にマウスポインタを近づけると >その中に入っているものが確認出来るのはご存じですよね？
最近 やっと カーソルをゆっくり動かすと 数字がなどが出てくるので、 なるほど 便利だと気づきました。教本で学習していないとこんな初歩・基本を失しているのです。
＞ ＞初期値に数値を入れておかないいけない（無害な１とした） ＞ この部分がどういった事かよく分かりません。
For ir = 2 To UBound(tbl1, 1)
' tbl1(ir, 15) = 1
Next 'For ir = 2
と初期値を数値にしておかないと
If tbl1(tbl1(ir, 15), 15) <> ir And tbl1(ir, 1) <> "" Then '
で irは2、tbl1(ir, 15)はEmpty、tbl1(tbl1(ir, 15), 15)は Index範囲外となり
エラーで停止です。
tbl1が数値と宣言されていないので、empty が0とは決まっていないので、
結果のようになったと理解します。それで 初期値１を入れました。
よろしいでしょうか？
＞ 必要は無いんじゃないかと。。。。 ＞ そこまでしなくても チェック済みかどうかは判定出来るのですから。 当該の行が既にチェック済みかどうかは 例えば if tbl1(ir, 15) > 1 then でわかるというご指摘でしょうか ？ なるほど やってみますと 動作はOKでした。 すると 先の 初期値は１とせずとも Emptyとしたままで If tbl1(ir, 15) = "" And tbl1(ir, 1) <> "" Then ' でチェック済み判定ができることになりました（動作OK）。 この理解で よいでしょうか？ （はんにゃ
＞tbl1が数値と宣言されていないので、empty が0とは決まっていないので、 ＞結果のようになったと理解します。それで 初期値１を入れました。 ＞よろしいでしょうか？
タブンよろしくありません。。。 正確にわかっていれば「数値とEmptyでは比較不能」 と言う表現には成らないと思うので。
エクセル君は『INDEXが有効範囲に無い』と言っています。 tbl1は tbl1(1 to 最終行 , 1 to 15)の大きさしか無いのに tbl1(0, 15)「0行目,15列目の値は何？」とはんにゃさんが聞くので 『はぁっ？１行目からでしょ！１行目！！０行目なんて無いよ。』 と言っています。
初期値に「1」を入れると言うことは、過去に見つかって居なかったら tbl1(1, 15)「1行目,15列目の値は何？」と確認しているので たまたま Cells(1, 15) に何か値が入っていて それをコード内でリセット（Emptyや""等）していなかった場合で さらに ir と一致して仕舞ったら 意図しない動きになるでしょう。
＞数値とEmptyでは比較不能
と思ったら・・・と言うか 思ったことは
簡単に確認出来ることなら、確認しておかれるのが良いでしょう。
例えば↓の様な感じで。
Sub test()
Dim x, r As Long
r = 1
MsgBox "等しい？ " & (x = r)
MsgBox "等しくない？ " & (x <> r)
End Sub
比較出来ますから、別の所に問題が有ると分かりますね。
＞初期値は１とせずとも Emptyとしたままで 今回は、シート上のデータを取り込んで使用しているので Emptyを入れる作業はしておいてください。
＞ If tbl1(ir, 15) = "" And tbl1(ir, 1) <> "" Then '
＞でチェック済み判定ができることになりました（動作OK）。
えっと・・・↓でやって居られましたよね？
If tbl1(ir, 7) = 1 And tbl1(ir, 1) <> "" Then '
ですから、既にクリアして居られる部分かと思っていたのですが。。。
それで、ローカルウィンドウは表示させているのですか？ これを使わないなら tbl1の右側を使っている利点があまりないのですし リセット作業が必要に成るので、寧ろ弊害に成るのですが。
(HANA)
ありがとうございます。 tbl1に数値で初期化していないと Emptyは０とみなされる（同じ）であるので、ir ループの使い始めで tbl1(ir, 15)=0 で、 tbl1(tbl1(ir, 15), 15)は「0行目,15列目の値」となって、 存在しないエラー。わかりなました。
Sub test()
Dim x
Dim r,s As Long
r = 1: s= 0
MsgBox "x=" & x & "r=" & r & "等しい？ " & (x = r)
MsgBox "等しくない？ " & (x <> r)
MsgBox "x=" & x & "s=" & s & "等しい？ " & (x = s)
MsgBox "等しくない？ " & (x <> s)
End Sub
でみるとxは空でも数値とは比較自体はでき、空と０とは同じと答えはでる。
なるほど。
If tbl1(ir, 7) = 1 And tbl1(ir, 1) <> "" Then '
でも、クリアしていました。
その上の誤解から （わざわざ）初期値１をしないといけないので
それを省くため（初期値Emptyのままで）
If tbl1(ir, 15) = "" And tbl1(ir, 1) <> "" Then '
としました。
でも
> 今回は、シート上のデータを取り込んで使用しているので
> Emptyを入れる作業はしておいてください。
と やはりあえて初期値Empty設定なら 設定することは
If tbl1(ir, 7) = 1 And tbl1(ir, 1) <> "" Then '
でも同じことです。これが以前言われたもう一つフラグを必要とするだろうといわれたことだと
理解しました。
あえて言えば せっかくのメモリですから 単なる１でなく、対の行番を記憶するとなにかと
便利かとおもいます
例えば tbl1(*、15)を以下Sheets("データ表 (2)") に表示させて その数値を観察しました。
ローカルウィンドウとは
With Sheets("データ表 (2)") 'tbl1を書き出す
.Cells.ClearContents
.Range("A1").Resize(UBound(tbl1, 1), 15) = tbl1 '
End With
で良いでしょうか。
>tbl1の右側を使っている利点があまりないのですし リセット作業が必要に成るので、寧ろ弊害に成るのですが。
なにかしておいた方がよろしいのであれば どうすることでしょうか？
リセット作業とは？
現状は
Private Sub DoituNin(tbl1, nn)
Dim msgres As VbMsgBoxResult
Dim ir As Long, irg As Long
Dim xrb As Long, xcb As Long, xre As Long, xce As Long
'tbl1(ij, 15)DoituNin検索のIndes ' 既出の再確認を避ける
'xrb = 1 '左端セル行番号 'xcb = 2 '左端セル列番号
'xre = 3 '右端セル行番号 'xce = 4 '右端セル列番号
For ir = 2 To UBound(tbl1, 1)
tbl1(ir, 15) = ""
Next 'For ir = 2
'リスト内の同一人候補を検出・手動確認しました｡
For ir = 2 To UBound(tbl1, 1)
' If tbl1(tbl1(ir, 15), 15) <> ir And tbl1(ir, 1) <> "" Then '
' If tbl1(ir, 15) = 1 And tbl1(ir, 1) <> "" Then '
If tbl1(ir, 15) = "" And tbl1(ir, 1) <> "" Then '
For irg = 2 + 1 To UBound(tbl1, 1)
If irg <> ir And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 And tbl1(irg, 10) = tbl1(ir, 10) Then
tbl1(irg, 15) = ir: tbl1(ir, 15) = irg
If MsgBox("the same? " & ir & tbl1(ir, 1) & " " & tbl1(ir, 10) & vbLf & "as " & irg & tbl1(irg, 1) & " " & tbl1(irg, 10), vbYesNo) = vbYes Then
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
xre = tbl1(irg, 13) '= tbl1(irg, 8) - nn + 1 '生年の行番地 西暦変換済み
xce = tbl1(irg, 14) '
'MsgBox xrb & "行" & xcb & "列セルから" & xre & "行" & xce & "列セルから線引き"
Call KankeiSen(xrb, xcb, xre, xce)
Exit For
Else:
Exit For
End If 'If MsgBox("the same ?
End If 'If ir <> irg And InStr(tbl1(irg, 1),
Next 'For irg =
End If 'If tbl1(ir, 1)
Next 'For ir = 2
End Sub
'------ .Find
＞これが以前言われたもう一つフラグを必要とするだろうといわれたことだと ＞理解しました。 私が言ったのは「フラグ用の列をもう一つ用意する」ですね。 フラグは【それぞれの行に対して】一つで良いです。
はんにゃさんが当初書いておられたコードでは 全体で、フラグ用の変数が一つしかありませんでした。 すると「前回どうだったか」という情報しか残りません。 このコードで必要な情報は「前回」だけの事だけでなく 【これまでに】その行はチェック済みか？ という情報でしたので、やはり それぞれの行にフラグを付けておくのが良いと思いました。
＞あえて言えば せっかくのメモリですから 単なる１でなく、 ＞対の行番を記憶するとなにかと ＞便利かとおもいます はい。そのようにしておいた方が、今後利用できる可能性があるので 良いと思います。（私にはその様な発想はありませんでしたが。。。）
15列目をその様に使うなら「フラグ用の列」ではなく 「検索結果記入列」と呼ぶ方が状況に合っているかもしれませんね。
＞リセット作業とは？
ご提示のコード内の
For ir = 2 To UBound(tbl1, 1)
tbl1(ir, 15) = ""
Next 'For ir = 2
の部分のことです。
もしもワークシート上で15列目に何かデータが入っていて それが処理に影響を及ぼすといけないので わざわざ「=""」なんて処理をしていますね。
例えば、新しく変数を一つ用意して Redim で大きさを決める等で使用した場合 最初は値は入っていないので 「=""」なんてする必要がなくなります。
＞ローカルウィンドウとは ＞・・・（中略）・・・ ＞で良いでしょうか。 違います。
ローカルウィンドウは、VBEのメニューの 表示(V)→ローカルウィンドウ(S) で表示させるウィンドウの事です。
実行中のコードの中で使用されている変数と その内容を、このウィンドウで確認できます。
例えば、
Sub test2() '1
Dim i As Long, x '2
ReDim x(1 To 3) '3
For i = 1 To 3 '4
x(i) = i '5
Next '6
End Sub '7
のコードをステップインで実行します。
最初、ローカルウィンドウには何も表示がありません。 1が黄色くなって止まったとき i（値 0）とx（値 Empty値）が表示されます。 3の行を超えると x の前にプラスマークが出ますね。 このプラスマークを押して開くと x(1) Empty値 x(2) Empty値 x(3) Empty値 と表示されます。 この段階では、iの値は 0 のままです。 4の行を超えると i の値が 1 になります。 x は変わらず。 5の行を超えると i の値は 1 のままで x(1) の値が 1 になります。 以降、ループ処理に入り 4,5,6が繰り返され そのたびに 該当する変数の値が変わります。 7行目を超えると マクロが終わるので ローカルウィンドウの表示はなくなります。
確認していただけたら 今回のコードで tbl1を確認してみてください。 行ごとに、各列の値を確認することができます。
例えば、tbl1の8列目は、生年が西暦で入っていますが コード実行中に「どうもこのあたりがおかしぞ？」ってなった時に tbl1の該当行の[+]を開けば、2,3列目の値を簡単に確認できますね。 2,3列目（和歴,年月日）のデータを見て 8列目のデータが得られるなら コードの他の部分がおかしくて、 得られないなら8列目を作成するコードがおかしい 事が分かります。
もしも、tbl1とは違う変数に 8列目以降の情報を書いていた場合 その変数を開いて データを確認して tbl1も開いて、元になるデータを確認して・・・ と、二つの変数を行ったり来たりしながら確認することになります。
例えば、
[A] [B]
[1] 1 A
[2] B
[3] 2 C
Sub test3()
Dim tbl, i As Long
tbl = Range("A1:B3")
For i = 1 To 3
If tbl(i, 1) <> "" Then
tbl(i, 2) = tbl(i, 1) + 1
Else
tbl(i, 2) = ""
End If
Next
End Sub
'------
Sub test4()
Dim tbl, i As Long, x
tbl = Range("A1:A3")
ReDim x(1 To 3, 1 To 1)
For i = 1 To 3
If tbl(i, 1) <> "" Then
x(i, 1) = tbl(i, 1) + 1
End If
Next
End Sub
こんな違いです。
test3の tblの2列目と test4の x に同じデータが出来上がります。
test3 では、tbl(i, 2) = "" が必要ですが tbl(2 , 2)のデータに疑問を感じた時 ローカルウィンドウで tbl の 2行目を開けば 二つの値を簡単に見比べることができます。
test4 では、xは新しい変数なので ="" は不要ですが x(2 , 1)のデータに疑問を感じた時 ローカルウィンドウで tbl の 2行目を開き x の 2行目も開いて 見比べる必要があります。
一つずつくらいなら、大したこともないのですが これが連続して あっちを開いて こっちを開いて 確認したら、次を開いて こっちも開いて なんてやってやるのは、結構手間に思います。
それで、今回は データ範囲の隣に大きく範囲をとりました。
私が作成した部分では各行は一回は必ず処理をするので その時に（入れるものがない時に）"" を入れてリセットとしています。 test3の様なコードの作りです。計算しなかった時に「""」を入れる。
今回の様な使用方法だと、どこにどの順番で値が入っていくのか
分からないので、もしかしたら Preserve を使って
Sub TEST5()
Dim tbl, i As Long
tbl = Range("A1:A3")
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2)
For i = 1 To 3
If tbl(i, 1) <> "" Then
tbl(i, 2) = tbl(i, 1) + 1
End If
Next
End Sub
の様にした方が良かったかもしれませんね。
(HANA)
詳しい ご教授ありがとうございます。
検索結果記入列は 同一人対の行番 と名前づけしました。
最後の件ですが
With Sheets("データ表")
'tbl1(ij, 1)名前 tbl1(ij, 2)生元号 tbl1(ij, 3)生年 tbl1(ij, 4)没元号 tbl1(ij, 5)没年
'tbl1(ij, 6)関係 tbl1(ij, 7)備考
'8:生年(西暦) or ？ or 未入力で""、9: 没年(西暦) or ？ or 未入力で""
'10:生年月日(B列 & C列) 11:没年月日(D列 & E列) 12:享年フラグ 13:系譜図セル行番 14:系譜図セル列番
'tbl1(ij,15) DoituNin検索のIndes ' 既出の再確認を避ける
'tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 12)
'tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 14) 'セル位置記録用を増す
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 15) '同一人対の行番
End With
の後で
With Sheets("系譜図")
略
'仮に値を入れて置く
For ij = 2 To UBound(tbl1, 1)
tbl1(ij, 13) = "": tbl1(ij, 14) = "" '
Next
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 7) ' ="" の替わり
ここで無効になりました。
preserve の理解を していないようです。
[既存の配列に格納されている値を失うことなく、配列の最後の次元の要素数を変更する場合に使用する]
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 15) '同一人対
の替わりに書くのでしょうか？
コードとは別ですが 同一人確認を If irg <> ir And InStr(tbl1(irg, 1), tbl1(ir, 1)) > 0 And tbl1(irg, 10) = tbl1(ir, 10) Then の名前と生年月日の一致でしているのですが、 世の中に同姓同名かつ生年月日が同じ事例が（Web上で）あるのですね。 これだと同名ならば なおさらありうるわけで しっかりデータ表をみて 本気で確認しないといけない。
そうなると一度確認すると 後で出現する 第２の同名同生年月日人との対応を見つけないので 厳密に言うと現在のコードでも まだ問題が残っている。！あ〜！。
（はんにゃ
＞厳密に言うと現在のコードでも まだ問題が残っている。！ ですよね。
＞3つ以上の行間で対応はないという前提です。 この前提が本当にそれでよいのか 疑問だったのですが。
ただ、それは「三人 年子になる」とか「双子が生まれる」とか 言う可能性から比べると、低いと思います。 現在のコードでは、この部分は未対応のままだと思いますので。
さて、preserve に付いてですが。。。
＞ ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 7) ' ="" の替わり ＞ ここで無効になりました。 何をするのか良く分かりませんが （無効になった ってのが何を現して居るのかも分かりませんが） tbl1の大きさを変更するなら テーブルの変数名は tbl1 ですね？ ただ、そう言う問題では無いですね。
えっと。。。
現在tbl1に
.Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 15)
の範囲のデータを取り込んで居ますね？
でも、本当は 6列目までのデータが欲しいだけで 7〜15列目は、そのスペースが欲しいだけです。 （シートに入力されているデータが欲しいわけではない。）
例えば、変数xを用意して ReDim x(・・・とやると 好きな大きさのスペースが作れて その中身は 空です。 この 空のスペースが tbl1の7列以降にも欲しいだけなんです。
そこで 「6列目までのデータを取り込んで その後、空のスペースを 9列分（15列目まで）増やせればよいのに。」
で、登場するのが ReDim Preserve です。
好きな範囲のスペースが欲しいんだから と
tbl = Range("範囲").Value
ReDim tbl(・・・・・
とやると、せっかく取り込んだデータまで
消えてしまいますからね。
test5は 1列目（A列）のデータを取り込んで その後、空のスペースを 1列分（2列目まで）増やしています。
ローカルウィンドウを確認しながら 実行してみて下さい。
tbl = Range("A1:A3")
の行が済んだ段階では、tblは 3行×1列の大きさです。
[-]tbl
[-]tbl(1)
tbl(1,1) ←列は１列分しかない
[+]tbl(2)
[+]tbl(3) ←行は３行分
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2)
の行が済むと、tblは 3行×2列の大きさに変わって
[-]tbl
[-]tbl(1)
tbl(1,1)
tbl(1,2) ←２列目が増える
[+]tbl(2)
[+]tbl(3) ←行は３行分
内容は、全てEmptyに成ってしまうのではなく
1列目は A1:A3のデータが残ったままで
2列目は 全てEmptyの状態ですね。
だから、test3の様に
Else
tbl(i, 2) = ""
と、値を「=""」にする必要が無くなります。
変更するなら
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 6)
で、データ部分のみをまず取り込んで その後
ReDim Preserve tbl1(1 To UBound(tbl1, 1), 1 To 15)
で、範囲を拡張します。
すると、ReDim Preserve 実行前は6列目までしか無かったのに 実行後は 7列目以降15列目までの 空のスペースが出来ますね？
(HANA)
ありがとうございました。
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 15) ' ="" の替わり
のエラーはtbl1の誤りでした。それと全角スペースが有ったみたい（コンパイラエラーの無効？）
With Sheets("データ表")
'tbl1(ij, 1)名前 tbl1(ij, 2)生元号 tbl1(ij, 3)生年 tbl1(ij, 4)没元号 tbl1(ij, 5)没年
'tbl1(ij, 6)関係 tbl1(ij, 7)備考
'8:生年(西暦) or ？ or 未入力で""、9: 没年(西暦) or ？ or 未入力で""
'10:生年月日(B列 & C列) 11:没年月日(D列 & E列) 12:享年フラグ 13:系譜図セル行番 14:系譜図セル列番
'tbl1(ij,15) DoituNin検索のIndes ' 既出の再確認を避ける
tbl1 = .Range("A1").Resize(.Range("A" & Rows.Count).End(xlUp).Row + 1, 7)
ReDim Preserve tbl1(1 To UBound(tbl1, 1), 1 To 15) ' 増設 tbl1(ij, 8)〜tbl1(ij, 15) = "" の替わり
End With
で正常に値が入り 動きました。
＞ただ、それは「三人 年子になる」とか「双子が生まれる」とか ＞現在のコードでは、この部分は未対応のままだと思いますので。
'双子の場合を想定して、書き加えてあります。
x(xr, xc + 1) = x(xr, xc + 1) & " " & sba & knm(tbl1(ij, 1), tbl1(ij, 9)) '名前 逝去付け '系譜線の生年に性記号と故などを氏名につける
結果
｜ 昭和43.8.30〜昭和43.8.30〜
▼英子 ▼智子
△航
「三人 年子になる」
' 年子の場合の生年の記載 'これからの氏名行に 前出名前の生年らが既に記載 がある時 上行に移動する
If x(xr, xc + 2) <> "" And x(xr - 2, xc + 2) = "" Then
x(xr - 2, xc + 2) = x(xr, xc + 2) '年子の前の子の1行上に すなわち2行上
x(xr, xc + 2) = ""
結果 ｜ 1802.3.1〜 ▼仮娘2 1803.11.1〜 ▼仮娘 △故_伊右衛門 = 文化?〜安政4.6.30享年？
双子と、三人年子は対応済みでしたか。
双子を同じセルに書き出すなら KankeiSenが重なりませんか？
まぁ、行き先は違うので 完全に重なることは無いと思いますが。
(HANA)
書き忘れてました。
せっかく書いて居られるので。。。 ＞双子を同じセルに書き出すなら ＞KankeiSenが重なりませんか？ この辺りは、私にとってはどうでも良くて （じゃあこうしたら？ って案も特に無いですし。） それよりも KankeiSen のコード内の With の使い方を もう一度整理されるのが良いと思います。
また、コメントが延び延びに成りましたが ＞c.Addressではそのまま使えないのですが、C.Address.columsのような ＞行、列番を 引き出すものはありませんでしょうか この時の場合、cは Set c = Selection.Find(tbl1(ir, 1), LookIn:=xlValues, LookAt:=xlPart) Set c = Selection.FindNext(c) の様にしてありますので 難しく考えなくても、c.Column とか、c.Row で行、列番号が得られると思います。 まぁ、分からなくても 後ろに Row とか Rows とかテキトウにつけて やってみられるのが良いと思いますよ。 戻り値の違いで、Row と Rows の違いが 明確に認識出来る様になるかもしれませんし。
そうそう、議題のコードに関してですが
（今後変更なさる部分に関わる可能性が高いですが）
Exit For
Else:
Exit For
メッセージボックスへの返答が Yes でも No でも Exit For するなら
Ifの外に出しておいても良いのではないかと思います。
(HANA)
>双子を同じセルに書き出すなら KankeiSenが重なりませんか？ そうです。行き先が同じ生年の婚姻者であると 同じ行での線引きになるので 見苦しいですが、 ないことを期待する。
>Private Sub KankeiSen(xrb, xcb, xre, xce, tbl1, irg) は
With Sheets("系譜図")
If xrb = xre And InStr(Sheets("系譜図").Range("D2").Cells(xre, xce), "=") > 0 Then '同じ生年での婚姻関係線
略
dblBeginX = .Range("D2").Cells(xrb, xcb).Left + Len(.Range("D2").Cells(xrb, xcb)) * 10 'dblBeginX = .Left + .Width / 2
略
End If ' If xrb = xre And InStr
End With
End Sub
に出来ました。
しかし 最後まで残ったのが
With Sheets("系譜図").Shapes.AddLine(dblBeginX, dblBeginY, dblEndX, dblEndY).Line
です
.Shapes.AddLine(dblBeginX, dblBeginY, dblEndX, dblEndY).Line
としてもNGでした。
なにか書き方があるでしょうか？
> Exit For > Else: > Ifの外に出しておいても良いのではないかと思います。 直しました。
> c.Column とか、c.Row で行、列番号 わかりました。
＞しかし 最後まで残ったのが
＞With Sheets("系譜図").Shapes.AddLine(dblBeginX, dblBeginY, dblEndX, dblEndY).Line
＞です
＞なにか書き方があるでしょうか？
こちらで簡単に試せるサンプルコードを載せられるのが
良いと思います。
もしかしたら、そのコードと一緒に 新規に質問なさった方が良いかもしれませんね。 私は、図形関係は分からないですし スレも長くなっていますので。
(HANA)
＞ こちらで簡単に試せるサンプルコードを載せられるのが 良いと思います。 ＞ 新規に質問なさった方が良いかもしれませんね。
はい。その部分だけの実行コードをつくり 新規質問します。 この課題では前課題に引き続いてお世話になりました。一応のレベル（コードではなく、結果機能で） で満足します。 あと ７列の備考（画像ファイル名を含め）の貼り付ける（コメントのように位置を後で変えられ、かつ 関係矢印線が移動しても両端が離れないようにする）ことをします。 また ご興味を持っていただければ よろしく おねがいします。 （はんにゃ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.