Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5488 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【50405】直線のすぐ下にテキストボックスを作成 ABC 07/7/24(火) 0:07 質問[未読]
【50407】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/24(火) 2:15 発言[未読]
【50408】Re:直線のすぐ下にテキストボックスを作成 ABC 07/7/24(火) 2:27 お礼[未読]
【50409】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/24(火) 2:57 発言[未読]
【50421】Re:直線のすぐ下にテキストボックスを作成 ABC 07/7/24(火) 19:59 質問[未読]
【50432】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/24(火) 22:21 発言[未読]
【50433】Re:直線のすぐ下にテキストボックスを作成 ABC 07/7/24(火) 23:23 お礼[未読]
【50434】Re:直線のすぐ下にテキストボックスを作成 今田 07/7/25(水) 0:24 質問[未読]
【50435】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/25(水) 2:36 発言[未読]
【50438】Re:直線のすぐ下にテキストボックスを作成 今田 07/7/25(水) 10:35 お礼[未読]
【50439】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/25(水) 11:19 発言[未読]
【50443】Re:直線のすぐ下にテキストボックスを作成 今田 07/7/25(水) 19:49 お礼[未読]
【50444】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/25(水) 20:10 発言[未読]
【50446】Re:直線のすぐ下にテキストボックスを作成 今田 07/7/26(木) 1:26 お礼[未読]
【50500】Re:直線のすぐ下にテキストボックスを作成 ＡＢＣ 07/7/29(日) 9:09 質問[未読]
【50501】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/29(日) 14:48 発言[未読]
【50504】Re:直線のすぐ下にテキストボックスを作成 ＡＢＣ 07/7/30(月) 2:31 質問[未読]
【50506】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/30(月) 11:07 発言[未読]
【50405】直線のすぐ下にテキストボックスを作成
質問  ABC  - 07/7/24(火) 0:07 -
引用なし
パスワード
   シート上のどこかに、長さの決まっていない直線を真横に引いた時に、
その引いた直線のほぼ真ん中のすぐ下にテキストボックスが自動的に
作成される。ちなみに、テキストボックスの大きさは１０ポイントの
文字が２字入るぐらいのサイズ。

このようなことが可能でしょうか？可能であればそのコードを教えて
ください。
【50407】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/24(火) 2:15 -
引用なし
パスワード
   ▼ABC さん：
こんにちは。
>自動的に
はちょっと高度になります。
（多分^ ^;...でもLineを引くところからマクロ化すればいいかも）

Sub Macro1()
　　Dim L As Single
　　Dim T As Single
　　
　　With ActiveSheet
　　　　With .Lines(.Lines.Count)
　　　　　　L = .Left + .Width / 2
　　　　　　T = .Top
　　　　End With
　　　　With .TextBoxes.Add(L - 8, T, 16, 16) '大きさは適当に変更してください。
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.VerticalAlignment = xlCenter
　　　　End With
　　End With
End Sub
これをショートカットキーやボタンなどに登録して実行。
...辺りで妥協されてはいかがでしょう。
【50408】Re:直線のすぐ下にテキストボックスを作成
お礼  ABC  - 07/7/24(火) 2:27 -
引用なし
パスワード
   Ned さんこんばんは
早速ためします。ありがとうございます
【50409】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/24(火) 2:57 -
引用なし
パスワード
   ▼ABC さん：
>...でもLineを引くところからマクロ化すればいいかも
一応書いときますね

Option Explicit
Dim flg As Boolean

Sub test1()
　　CommandBars.FindControl(ID:=130).Execute
　　flg = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim L As Single
　　Dim T As Single
　　
　　If flg Then
　　　　With ActiveSheet
　　　　　　With .Lines(.Lines.Count)
　　　　　　　　L = .Left + .Width / 2
　　　　　　　　T = .Top
　　　　　　　　.Height = 0
　　　　　　End With
　　　　　　With .TextBoxes.Add(L - 8, T, 16, 16)
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　End With
　　　　End With
　　　　flg = False
　　End If
End Sub

標準モジュールではなくて、該当シートタブ右クリック[コードの表示]で出てくる
シートモジュールに上記コードを置いて、Sub test1()を実行すると
直線を引く用の ＋ カーソルになります。
直線引き終えたら、どこでも良いのでセル選択すればOK。
【50421】Re:直線のすぐ下にテキストボックスを作成
質問  ABC  - 07/7/24(火) 19:59 -
引用なし
パスワード
   Ned さん、再びありがとうございます。

50064に右ｸﾘｯｸｲﾍﾞﾝﾄで直線を引くｺｰﾄﾞの説明を見つけました。自分としては是非そのｺｰﾄﾞを参考にして、直線は下記のｺｰﾄﾞを使って作成。そして、最初の質問にある、その引いた直線のほぼ中央の真下にﾃｷｽﾄﾎﾞｯｸｽを作成する、をNedさんから回答いただいたｺｰﾄﾞと併せて目的を達成させたいのですがそれがまるでわかりません。なんとしても実現させたいと思っています。よろしくお願いします。


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
>　　Dim l_rng As Range
>　　If Target.Count <> 1 Then
>　　　 MsgBox "単一セルに限ります"
>　　　 Exit Sub
>　　　 End If
>　　If f_rng Is Nothing Then
>　　　 Set f_rng = Target
>　　　 Application.StatusBar = "直線の終点を右クリックしてください"
>　　Else
>　　　 If f_rng.Left > Target.Left Then
>　　　　　Set l_rng = f_rng
>　　　　　Set f_rng = Target
>　　　 Else
>　　　　　Set l_rng = Target
>　　　　　End If
　　　　With Me.Lines.Add(f_rng.Left + f_rng.Width, f_rng.Top, _
　　　　　　　　　　　　 l_rng.Left, l_rng.Top)
　　　　　　 .ShapeRange.Line.Weight = 0.5
　　　　　　 End With
>　　　 Set f_rng = Nothing
>　　　 Application.StatusBar = False
>　　　 End If
>　　Cancel = True
>End Sub
【50432】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/24(火) 22:21 -
引用なし
パスワード
   ▼ABC さん：
ん...深く考えず単純に挿入するとしたら
>>Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
>>　　Dim l_rng As Range
　　Dim L As Single
　　Dim T As Single

>>　　If Target.Count <> 1 Then
>>　　　　MsgBox "単一セルに限ります"
>>　　　　Exit Sub
>>　　End If
>>　　If f_rng Is Nothing Then
>>　　　　Set f_rng = Target
>>　　　　Application.StatusBar = "直線の終点を右クリックしてください"
>>　　Else
>>　　　　If f_rng.Left > Target.Left Then
>>　　　　　　Set l_rng = f_rng
>>　　　　　　Set f_rng = Target
>>　　　　Else
>>　　　　　　Set l_rng = Target
>>　　　　End If
>　　　　With Me.Lines.Add(f_rng.Left + f_rng.Width, f_rng.Top, _
>　　　　　　　　　　　　　l_rng.Left, l_rng.Top)
>　　　　　　.ShapeRange.Line.Weight = 0.5
　　　　　　.Height = 0
　　　　　　L = .Left + .Width / 2
　　　　　　T = .Top
　　　　End With
　　　　With Me.TextBoxes.Add(L - 8, T, 16, 16)
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.VerticalAlignment = xlCenter
>　　　　End With
>>　　　　Set f_rng = Nothing
>>　　　　Application.StatusBar = False
>>　　End If
>>　　Cancel = True
>>End Sub
こんな感じ...
【50433】Re:直線のすぐ下にテキストボックスを作成
お礼  ABC  - 07/7/24(火) 23:23 -
引用なし
パスワード
   Ned さん、まことにありがとうございました
【50434】Re:直線のすぐ下にテキストボックスを作成
質問  今田  - 07/7/25(水) 0:24 -
引用なし
パスワード
   ▼Ned さん：
途中割り込みですみません
これは便利と思い利用したいのですが
チョット私の使いたいものに変更したいのですが
教えて下さい
まずテキストボックスをラインの中央の直上に枠線なしで配置したいのですが
かつテキストボックスをアクティブな状態にできますか？
マクロの記録も試してみたのですがうまくいきませんでした
よろしくお願いします。

Sub test1()
　　CommandBars.FindControl(ID:=130).Execute
　　flg = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim L As Single
　　Dim T As Single
　
　　If flg Then
　　　　With ActiveSheet
　　　　　　With .Lines(.Lines.Count)
　　　　　　　　L = .Left + .Width / 2.5
　　　　　　　　T = .Top
　　　　　　　　.Height = 0
　　　　　　End With
　　　　　　With .TextBoxes.Add(L - 8, T, 40, 14)
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　.VerticalAlignment = xlCenter
'　　　　　　　　.Line.Weight = 0
　　　　　　End With
　　　　End With
　　　　flg = False
　　End If
End Sub


>>...でもLineを引くところからマクロ化すればいいかも
>一応書いときますね
>
>Option Explicit
>Dim flg As Boolean
>
>Sub test1()
>　　CommandBars.FindControl(ID:=130).Execute
>　　flg = True
>End Sub
>
>Private Sub Worksheet_SelectionChange(ByVal Target As Range)
>　　Dim L As Single
>　　Dim T As Single
>　　
>　　If flg Then
>　　　　With ActiveSheet
>　　　　　　With .Lines(.Lines.Count)
>　　　　　　　　L = .Left + .Width / 2
>　　　　　　　　T = .Top
>　　　　　　　　.Height = 0
>　　　　　　End With
>　　　　　　With .TextBoxes.Add(L - 8, T, 16, 16)
>　　　　　　　　.HorizontalAlignment = xlCenter
>　　　　　　　　.VerticalAlignment = xlCenter
>　　　　　　End With
>　　　　End With
>　　　　flg = False
>　　End If
>End Sub
>
>標準モジュールではなくて、該当シートタブ右クリック[コードの表示]で出てくる
>シートモジュールに上記コードを置いて、Sub test1()を実行すると
>直線を引く用の ＋ カーソルになります。
>直線引き終えたら、どこでも良いのでセル選択すればOK。
【50435】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/25(水) 2:36 -
引用なし
パスワード
   ▼今田 さん：
こんにちは。
解決...と思って油断してました（笑
とりあえずDoubleClickイベントにかえてみました。

Option Explicit
Dim flg As Boolean

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
　　CommandBars.FindControl(ID:=130).Execute
　　flg = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim Lp As Single
　　Dim Tp As Single
　　Dim Wp As Single
　　Dim Hp As Single

　　If flg Then
　　　　With ActiveSheet
　　　　　　With .Lines(.Lines.Count)
　　　　　　　　Lp = .Left
　　　　　　　　Tp = .Top
　　　　　　　　Wp = .Width
　　　　　　　　Hp = .Height
　　　　　　End With
　　　　　　With .TextBoxes.Add(0, 0, 0, 0)
　　　　　　　　.ShapeRange.Line.Visible = msoFalse
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　.AutoSize = True
　　　　　　　　.Font.Size = 10
　　　　　　　　.Text = Wp '仮
　　　　　　　　.Left = Lp + (Wp - .Width) / 2
　　　　　　　　.Top = Tp + (Hp - .Height) / 2
　　　　　　　　.Select
　　　　　　End With
　　　　End With
　　　　flg = False
　　End If
End Sub
【50438】Re:直線のすぐ下にテキストボックスを作成
お礼  今田  - 07/7/25(水) 10:35 -
引用なし
パスワード
   ▼Ned さん：
こんにちわ
深夜に送信
ありがとうございます。
希望通りです
感謝！
【50439】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/25(水) 11:19 -
引用なし
パスワード
   ちょっと分割して、任意選択実行もできるようにしてみました。

'全てシートモジュール
Option Explicit
Dim flg As Boolean

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
　　CommandBars.FindControl(ID:=130).Execute
　　flg = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　If flg Then
　　　　Call LINETXT(Me.Lines(Me.Lines.Count))
　　　　flg = False
　　End If
End Sub

Private Sub LINETXT(ByRef LX As Line)
　　Const x As Single = 1!
　　Dim Lp　As Single
　　Dim Tp　As Single
　　Dim Wp　As Single
　　Dim Hp　As Single
　　Dim St　As String

　　With LX
　　　　Lp = .Left
　　　　Tp = .Top
　　　　Wp = .Width
　　　　Hp = .Height
　　End With
　　If Wp > Hp Then
　　　　St = "W " & Wp * x
　　Else
　　　　St = "H " & Hp * x
　　End If
　　With Me.TextBoxes.Add(0, 0, 0, 0)
　　　　.ShapeRange.Line.Visible = msoFalse
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　.AutoSize = True
　　　　.Font.Size = 9
　　　　.Text = St
　　　　.Left = Lp + (Wp - .Width) / 2
　　　　.Top = Tp + (Hp - .Height) / 2
　　　　.Select
　　End With
　　'CommandBars.FindControl(ID:=1401).Execute '必要なら
End Sub

Sub sampletest()
　　If TypeName(Selection) = "Line" Then
　　　　Call LINETXT(Selection)
　　End If
End Sub
【50443】Re:直線のすぐ下にテキストボックスを作成
お礼  今田  - 07/7/25(水) 19:49 -
引用なし
パスワード
   ▼Ned さん：
またまた
ありがとうございました。
goodです(^_^)/~
ちなみに罫線が多少斜めに引いた場合まっすぐに修正は
できませんか【50409】作品では出来ているようなのですが・・・

>ちょっと分割して、任意選択実行もできるようにしてみました。
>
>'全てシートモジュール
>Option Explicit
>Dim flg As Boolean
>
>Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
>　　Cancel = True
>　　CommandBars.FindControl(ID:=130).Execute
>　　flg = True
>End Sub
>
>Private Sub Worksheet_SelectionChange(ByVal Target As Range)
>　　If flg Then
>　　　　Call LINETXT(Me.Lines(Me.Lines.Count))
>　　　　flg = False
>　　End If
>End Sub
>
>Private Sub LINETXT(ByRef LX As Line)
>　　Const x As Single = 1!
>　　Dim Lp　As Single
>　　Dim Tp　As Single
>　　Dim Wp　As Single
>　　Dim Hp　As Single
>　　Dim St　As String
>
>　　With LX
>　　　　Lp = .Left
>　　　　Tp = .Top
>　　　　Wp = .Width
>　　　　Hp = .Height
>　　End With
>　　If Wp > Hp Then
>　　　　St = "W " & Wp * x
>　　Else
>　　　　St = "H " & Hp * x
>　　End If
>　　With Me.TextBoxes.Add(0, 0, 0, 0)
>　　　　.ShapeRange.Line.Visible = msoFalse
>　　　　.HorizontalAlignment = xlCenter
>　　　　.VerticalAlignment = xlCenter
>　　　　.AutoSize = True
>　　　　.Font.Size = 9
>　　　　.Text = St
>　　　　.Left = Lp + (Wp - .Width) / 2
>　　　　.Top = Tp + (Hp - .Height) / 2
>　　　　.Select
>　　End With
>　　'CommandBars.FindControl(ID:=1401).Execute '必要なら
>End Sub
>
>Sub sampletest()
>　　If TypeName(Selection) = "Line" Then
>　　　　Call LINETXT(Selection)
>　　End If
>End Sub
【50444】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/25(水) 20:10 -
引用なし
パスワード
   ▼今田 さん：
あら^ ^;余計な配慮でしたか...

Private Sub LINETXT(ByRef LX As Line)
　　Const x As Single = 1!
　　Dim Lp As Single
　　Dim Tp As Single
　　Dim Wp As Single
　　Dim St As String
　　
　　With LX
　　　　Lp = .Left
　　　　Tp = .Top
　　　　Wp = .Width
　　　　.Height = 0
　　End With
　　　　St = "W " & Wp * x
　　With Me.TextBoxes.Add(0, 0, 0, 0)
　　　　.ShapeRange.Line.Visible = msoFalse
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　.AutoSize = True
　　　　.Font.Size = 9
　　　　.Text = St
　　　　.Left = Lp + (Wp - .Width) / 2
　　　　.Top = Tp - .Height / 2
　　　　.Select
　　End With
　　'CommandBars.FindControl(ID:=1401).Execute '必要なら
End Sub
【50446】Re:直線のすぐ下にテキストボックスを作成
お礼  今田  - 07/7/26(木) 1:26 -
引用なし
パスワード
   ▼Ned さん：
何度も
ありがとうございました。
完璧でーす
またお願いします。
【50500】Re:直線のすぐ下にテキストボックスを作成
質問  ＡＢＣ  - 07/7/29(日) 9:09 -
引用なし
パスワード
   また教えていただきたいことがあります。５０４３２の回答だと２つ以上のセル間で直線を引くにはまったく問題ないのですが、今やりたいのは１つのセル内で直線を引くことです。右クリックイベントを用いて、１つのセル内を２度右クリックすることによってそれを可能にするにはどうすればいいでしょうか。よろしくお願いします
【50501】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/29(日) 14:48 -
引用なし
パスワード
   ▼ＡＢＣ さん：
こんにちは。
>右クリックイベントを用いて、１つのセル内を２度右クリックすることによって
これは必須条件ですか？
右クリックではなくて、左DoubleClickでよければ

'該当シートのシートモジュールに。
Option Explicit

Dim flg As Boolean

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
　　CommandBars.FindControl(ID:=130).Execute
　　flg = True
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　If flg Then
　　　　Call LINETXT(Me.Lines(Me.Lines.Count))
　　　　flg = False
　　End If
End Sub

Private Sub LINETXT(ByRef LX As Line)
　　Dim Lp As Single
　　Dim Tp As Single
　
　　With LX
　　　　Lp = .Left + .Width / 2
　　　　Tp = .Top
　　　　.Height = 0
　　End With
　　With Me.TextBoxes.Add(Lp - 8, Tp, 16, 16)
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　End With
End Sub

DoubleClickして線を引いたあと、別セル選択した時にTextBox追加します。
（同一セル内も複数セルに渡る場合も同じ動きです）
【50504】Re:直線のすぐ下にテキストボックスを作成
質問  ＡＢＣ  - 07/7/30(月) 2:31 -
引用なし
パスワード
   返事遅くなりました
Ned さんまことにありがとうございます。うーん、できれば右クリックがいいです。右クリックで１つのセル内に、セル幅の分の長さの直線を引きたいです。
【50506】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/30(月) 11:07 -
引用なし
パスワード
   ▼ＡＢＣ さん：
んー･･では、
>50064に右ｸﾘｯｸｲﾍﾞﾝﾄで直線を引くｺｰﾄﾞの説明を見つけました。自分としては是非そのｺｰﾄﾞを参考にして
これを尊重して
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
　　Dim l_rng As Range
　　Dim L As Single
　　Dim T As Single
　　Dim x As Single '■
　　
　　If Target.Count <> 1 Then
　　　　MsgBox "単一セルに限ります"
　　　　Exit Sub
　　End If
　　If f_rng Is Nothing Then
　　　　Set f_rng = Target
　　　　Application.StatusBar = "直線の終点を右クリックしてください"
　　Else
　　　　If f_rng.Address = Target.Address Then '■
　　　　　　Set l_rng = Target '■
　　　　　　x = l_rng.Height / 2 '■
　　　　ElseIf f_rng.Left > Target.Left Then '■
　　　　　　Set l_rng = f_rng
　　　　　　Set f_rng = Target
　　　　Else
　　　　　　Set l_rng = Target
　　　　End If
　　　　With Me.Lines.Add(f_rng.Left + f_rng.Width, f_rng.Top + x, _
　　　　　　　　　　　　　l_rng.Left, l_rng.Top + x) '■
　　　　　　.ShapeRange.Line.Weight = 0.5
　　　　　　.Height = 0
　　　　　　L = .Left + .Width / 2
　　　　　　T = .Top
　　　　End With
　　　　With Me.TextBoxes.Add(L - 8, T, 16, 16)
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.VerticalAlignment = xlCenter
　　　　End With
　　　　Set f_rng = Nothing
　　　　Application.StatusBar = False
　　End If
　　Cancel = True
End Sub
この程度で。
■が修正箇所です。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5488 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free