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で質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) エクセルで作った文章を図で貼り付けたが元のエクセルが削除したので図からエクセルに戻したい 4 2022/07/05 08:11
- その他(Microsoft Office) エクセルのマクロについて教えてください。 5 2023/01/21 09:39
- その他(Microsoft Office) ワードのマクロについて教えてください。 1 2023/01/22 11:43
- その他(Microsoft Office) パワーポイントやワード、エクセルでのスライドショーやテキストの微調整について 1 2023/01/12 05:50
- Illustrator(イラストレーター) イラストレーターで画像を適切な大きさで組み込みたい 2 2022/07/10 19:19
- 文学 漢文 1 2022/05/21 02:41
- Word(ワード) ワードの背面や前面 5 2023/01/28 11:50
- 年賀状作成・はがき作成 はがき作家 2 2023/05/12 06:00
- 文学・小説 日本の作家『三島由紀夫』の生き方には幕臣としての祖先の影響(永い家風)が色濃くあったのですか? 1 2022/12/01 01:32
- Excel(エクセル) エクセルでこのようなことはできますか? 3 2022/07/10 19:57
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
再登録可能時期
-
廃車 登録識別情報等通知書 が...
-
名義変更前に違反をされました
-
普通車を譲渡するときの自賠責...
-
ヤフーオークションの官公庁オ...
-
抹消と取消の違いについて
-
自動車税未払いの時
-
永久抹消する為に必要なものは?
-
一時抹消から永久抹消への書類...
-
一時抹消と、返納の違いについて
-
廃車 抹消登録の車台番号の桁...
-
名義変更後の車検証コピーの保...
-
自動車検査証記入申請書
-
離婚を検討中ですが嫁が実印な...
-
地元(出身地)のナンバーを取得...
-
個人事業、親名義の車の経費
-
実印を貸してと言われ悩んでいます
-
個人売買で車検残りがある軽自...
-
個人売買で車を売る事があるの...
-
所有者が死亡した車を名義変更(...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
長期愛用したクルマへの気持ち...
-
再登録可能時期
-
抹消と取消の違いについて
-
自転車の譲渡証明書について メ...
-
自動車 職権抹消について!
-
ドリームキャストの登録抹消の...
-
メルカリで自転車が売れてお相...
-
“強制抹消”車の登録は本当に不...
-
廃車 抹消登録の車台番号の桁...
-
ドリームキャスト破棄時の個人...
-
一時抹消と、返納の違いについて
-
至急!車税未納 抹消 新規登録...
-
一時抹消渡しについて
-
名義変更前に違反をされました
-
教えてgooの対処方法が未だに分...
-
一時抹消手続き(返納証明書)...
-
会員登録を「削除?」「抹消?」
-
中古車 名義変更 車検
-
車検証の紛失
-
車検切れ名義変更(一時抹消後名...
おすすめ情報