No.2ベストアンサー
- 回答日時:
エクセルVBAを使って、ツールらしきものを作ってみました。
新規ブックにSheet1(この名前のシートが必要。、他のシートでは、下記コードでは不可)を用意し、使うこと。
ーーーー
VBEの画面のModule1の画面に下記をコピーし貼り付ける。
Sub test01()
Application.ScreenUpdating = False
Cells.MergeCells = False
Cells.Clear
Worksheets("Sheet1").Cells.ColumnWidth = 2.5
For i = 1 To 100 Step 3
Cells(i, "A").RowHeight = 14
Cells(i + 1, "A").RowHeight = 14
Cells(i + 2, "a").RowHeight = 70
Next i
Application.ScreenUpdating = True
Range("A1") = "親子"
Range("A2") = "兄弟"
Range("A3") = "抹消"
Worksheets("Sheet1").ComboBox1.ListFillRange = "A1:A3"
End Sub
上記をコピーして、VBE画面のMojule1に張り付ける。
実行する(F5キーを押す)と、Sheet1が、原稿用紙のような枠線になる。
そしてコンボボックスが1つ出て、親子ー兄弟ー抹消の3項目が選べる。
ーーー
VBEのSheet1の「シートモジュール」の画面に、下記をコピーして、貼り付ける。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
c = Target.Column
r = Target.Row
'--
If Worksheets("Sheet1").ComboBox1 = "親子" Then
Target.Borders(xlLeft).Weight = xlThick
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Cells(r + 3, c).Borders(xlEdgeLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
'Exit Sub
'----
ElseIf Worksheets("Sheet1").ComboBox1 = "兄弟" Then
If Range(Cells(r + 2, c - 5), Cells(r + 2, c - 5)).Borders(xlLeft).LineStyle <> xlNone Then
MsgBox "右付け"
Range(Cells(r, c - 4), Cells(r, c - 1)).Borders(xlBottom).Weight = xlThick
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
Else
MsgBox "左付け"
Range(Cells(r, c), Cells(r, c + 3)).Borders(xlBottom).Weight = xlThick
'---
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
End If
'Exit Sub
'-----
ElseIf Worksheets("Sheet1").ComboBox1 = "抹消" Then
Range(Cells(r + 1, c - 1), Cells(r + 3, c)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.MergeCells = False
Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlNone
End If
End Sub
を貼り付ける。
ーーー
Sheet1の画面に戻り
256列ある列で、始祖(一番上先頭にくる(ひいおじいちゃんぐらい?)を真ん中列(100列目でCV列)あたりからはじめる。
ピラミッドがた・末広がりに広がるから。
ーーー
親子=垂直配置
コンボボックスを「親」を選んでおいて、右上セルをダブルクリック
すると、上ひげ+四角+下ひげが書かれる
ダブルクリックする位置と四角が書かれる位置をつかんでください。
ーーー
兄弟(姉妹)=水平配置
コンボボックスを「兄弟」を選んでおいて、右上セルをダブルクリックすると、カギ型上ひげ+四角+下ひげが書かれる。
左に上のカギひげを伸ばすか、右に伸ばすかは、プログラムで判断する。
ーーー
抹消=罫線抹消とセル結合を解除
名の通り。
どの範囲の罫線等が、抹消されるか、つかんでください。
ーーーーーー
練習が終わったら、編集ークリアー全てでA1:A3以外を抹消してください。
========
本番では、
セルの位置は、左右列は2列空けて、次ぎの2列の右側セルをダブルクリックするようにしてください。
行は上のひげのすぐ下の行を選びます。そしてダブルクリックします。
==ボックス等の位置は、ユーザーが責任を持って適当に決める主義の仕様になっていますからよろしく。
やはり簡単なメモでも事前に作ってから、エクセルシートに向かう、ことが必要と思います。
===全般に小生の力が不足しているのと、質問締め切りも気にしてやりましたので、至らない点はお許しください。
ーーー
注意
●抹消後に、不要な「ひげ」が残るかもしれませんが、お手数ですが、通常のエクセルの罫線抹消の操作で消してください。
●また、兄弟追加のとき、家系のツリーの右端にくる人のボックスがA-E列に、こないようにしてください。エラーが出ます。
●コンボボックスの位置の移動はデザインモードにして、CTRL+Xで切り取り、それから望みの場所でCTRL+Vで貼り付け移動してください。そしてデザインモードをOFFにする。
(ツールバーの定規と鉛筆のアイコンを、クリックして、へこましたり、戻したりするとデザインモードがON/OFF切り替えられます。)
No.4
- 回答日時:
こんにちは。
#1さんがWordでおっしゃっているので、Excelでは、組織図が該当します。
[組織図を出す]
挿入-図-組織図
組織図の描画領域と組織図ツールバーが出てきたら、領域の中のそれぞれの角丸の四角の枠のところで、右クリック
オートシェイプの書式設定-配置-方向(N)
文
字
列
を選びます。
色と線では、透明(塗りつぶしなし)にしたり、色を変えたりします。
(Excel2003)
No.3
- 回答日時:
#2です。
●#2で、説明でもれたところを補充します。
Sheet1にリストボックスを1つ貼り付ける。(コンボをリスト
ボックスに下記の理由で変更)
●改良する
(1)Sheet1を全部クリアしてやり直ししても大丈夫なように。
(2)コンボに比べ親子・兄弟・抹消が常時見えているし、選択分も色が付いて、見えているので。
Module1に貼り付けるコードを下記に改める。
Sub test01()
Application.ScreenUpdating = False
Cells.MergeCells = False
Cells.Clear
Worksheets("Sheet1").Cells.ColumnWidth = 2.5
For i = 1 To 100 Step 3
Cells(i, "A").RowHeight = 14
Cells(i + 1, "A").RowHeight = 14
Cells(i + 2, "a").RowHeight = 70
Next i
Application.ScreenUpdating = True
'---
Worksheets("Sheet1").ListBox1.Clear 'RemoveAllItems
Worksheets("Sheet1").ListBox1.AddItem "親子"
Worksheets("Sheet1").ListBox1.AddItem "兄弟"
Worksheets("Sheet1").ListBox1.AddItem "抹消"
End Sub
●関連して
Sheet1のシートモジュールに貼り付けるコードも修正
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
c = Target.Column
r = Target.Row
'--
If Worksheets("Sheet1").ListBox1 = "親子" Then
Target.Borders(xlLeft).Weight = xlThick
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Cells(r + 3, c).Borders(xlEdgeLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
'Exit Sub
'----
ElseIf Worksheets("Sheet1").ListBox1 = "兄弟" Then
If Range(Cells(r + 2, c - 5), Cells(r + 2, c - 5)).Borders(xlLeft).LineStyle <> xlNone Then
MsgBox "右付け"
Range(Cells(r, c - 4), Cells(r, c - 1)).Borders(xlBottom).Weight = xlThick
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
Else
MsgBox "左付け"
Range(Cells(r, c), Cells(r, c + 3)).Borders(xlBottom).Weight = xlThick
'---
Cells(r + 1, c).Borders(xlLeft).Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).Borders.Weight = xlThick
Range(Cells(r + 2, c - 1), Cells(r + 2, c)).MergeCells = True
Cells(r + 2, c - 1).Orientation = xlVertical
End If
'Exit Sub
'-----
ElseIf Worksheets("Sheet1").ListBox1 = "抹消" Then
Range(Cells(r + 1, c - 1), Cells(r + 3, c)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.MergeCells = False
Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlNone
End If
End Sub
●注意点(再説明)
2列x4行の、右上セルをクリックすると、その8つのセルに、兄弟の場合はそれにプラス線を3列伸ばして行きます。
このコツを覚えてください。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
- ・ゆるやかでぃべーと タイムマシンを破壊すべきか。
- ・「I love you」 をかっこよく翻訳してみてください
- ・歩いた自慢大会
- ・許せない心理テスト
- ・字面がカッコいい英単語
- ・昔のあなたへのアドバイス
- ・かっこよく答えてください!!
- ・あなたが好きな本屋さんを教えてください
- ・これ何て呼びますか Part2
- ・人生で一番思い出に残ってる靴
- ・ゆるやかでぃべーと すべての高校生はアルバイトをするべきだ。
- ・初めて自分の家と他人の家が違う、と意識した時
- ・単二電池
- ・チョコミントアイス
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
再登録可能時期
-
抹消と取消の違いについて
-
名義変更前に違反をされました
-
自転車の譲渡証明書について メ...
-
軽自動車の移転登録(名義変更...
-
他県ナンバーの一時抹消登録と...
-
400cc バイクの一時抹消手続き...
-
事故後の税金
-
抹消済みの中古車の登録に必要...
-
一時抹消
-
ドリームキャスト破棄時の個人...
-
用地買収に係る抵当権抹消費用
-
保険交渉中の一時抹消
-
私名義とはどういう意味ですか?
-
私が車を売った時に相手に渡す...
-
[実印を家族に貸せますか?]
-
車の個人売買について メルカリ...
-
個人事業、親名義の車の経費
-
ネットで車買いました!車検な...
-
個人売買で車を売る事があるの...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
抹消と取消の違いについて
-
再登録可能時期
-
ドリームキャストの登録抹消の...
-
“強制抹消”車の登録は本当に不...
-
自動車 職権抹消について!
-
一時抹消と、返納の違いについて
-
自転車の譲渡証明書について メ...
-
ドリームキャスト破棄時の個人...
-
名義変更前に違反をされました
-
廃車 抹消登録の車台番号の桁...
-
ヤフーオークションの官公庁オ...
-
メルカリで自転車が売れてお相...
-
RAID0のハードディスクの完全...
-
自動車の永久抹消登録の催告
-
査定価格0円の廃車になる車を廃...
-
一時抹消の車の名義変更について
-
一時抹消登録証明書って…
-
会員登録を「削除?」「抹消?」
-
所有者死亡後の廃車
-
一時抹消渡しについて
おすすめ情報