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:直線のすぐ下にテキストボックスを作成 ABC 07/7/29(日) 9:09 質問[未読]
【50501】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/29(日) 14:48 発言[未読]
【50504】Re:直線のすぐ下にテキストボックスを作成 ABC 07/7/30(月) 2:31 質問[未読]
【50506】Re:直線のすぐ下にテキストボックスを作成 Ned 07/7/30(月) 11:07 発言[未読]

【50405】直線のすぐ下にテキストボックスを作成
質問  ABC  - 07/7/24(火) 0:07 -

引用なし
パスワード
   シート上のどこかに、長さの決まっていない直線を真横に引いた時に、
その引いた直線のほぼ真ん中のすぐ下にテキストボックスが自動的に
作成される。ちなみに、テキストボックスの大きさは10ポイントの
文字が2字入るぐらいのサイズ。

このようなことが可能でしょうか?可能であればそのコードを教えて
ください。

【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:直線のすぐ下にテキストボックスを作成
質問  ABC  - 07/7/29(日) 9:09 -

引用なし
パスワード
   また教えていただきたいことがあります。50432の回答だと2つ以上のセル間で直線を引くにはまったく問題ないのですが、今やりたいのは1つのセル内で直線を引くことです。右クリックイベントを用いて、1つのセル内を2度右クリックすることによってそれを可能にするにはどうすればいいでしょうか。よろしくお願いします

【50501】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/29(日) 14:48 -

引用なし
パスワード
   ▼ABC さん:
こんにちは。
>右クリックイベントを用いて、1つのセル内を2度右クリックすることによって
これは必須条件ですか?
右クリックではなくて、左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:直線のすぐ下にテキストボックスを作成
質問  ABC  - 07/7/30(月) 2:31 -

引用なし
パスワード
   返事遅くなりました
Ned さんまことにありがとうございます。うーん、できれば右クリックがいいです。右クリックで1つのセル内に、セル幅の分の長さの直線を引きたいです。

【50506】Re:直線のすぐ下にテキストボックスを作成
発言  Ned  - 07/7/30(月) 11:07 -

引用なし
パスワード
   ▼ABC さん:
んー・・では、
>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