[[20041103121918]]　『二重線を書き込みたい』（ＭＡＴＵ）　ページの最後に飛ぶ

『二重線を書き込みたい』（ＭＡＴＵ）

教えてください！
エクセルで文字の上に訂正線と言いますか、二重線を書き込みたいのですがどのようにすれば
いいでしょうか？

 セルの書式設定の「フォント」タブの下線の設定に二重線がありますが、下線でなく
取り消し線を二重線にしたいと言う事ですか？
（ケン）

はい。下線ではなく文字の上に二重線を引きたいのですが。
（ＭＡＴＵ）

 オートシェイプの二重線を重ねるとか・・・
（ケン）

有難うございます。それも試しておりますが、非常に手間がかかるものですから、もう少し簡単にと思いまして・・・
すみません
（ＭＡＴＵ）

 一度、二重線をオートシェイプで描いておき、後はそれをCtrlを押しながら
任意の場所にドロップする。位しか・・・
他の方のご意見をお待ちください。
（ケン）

そうですね。何度もご返答いただき有難うございました。そのようにさせてもらいます。
有難うございました。
（ＭＡＴＵ）

 あっあっ、、二重線じゃないけど。。
せこく取り消し線で(^^;
（SoulMan）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    If Target.Font.Strikethrough = True Then
        Target.Font.Strikethrough = False
    Else
        Target.Font.Strikethrough = True
    End If
End Sub
シートの見出しを右クリック→コードを表示させて、そこに貼り付けます。
取り消し線を引きたいところをダブルクリック
取り消し線があったら、削除
なかったら線を書く。。。
ちょっと、せこいかな？？？

 (*'ω'*)......ん?
 単線の取り消し線ならボタンがあるじゃにゃいの・・・。
 （川野鮎太郎）

 (ﾟoﾟ)げっ!!ぎゃぁ～～～
退散
(SoulMan）

 ワードには二重取り消し線があるのに何でエクセルに無いんですかね。
 少し面白半分でやってみました。
 ※PCによってズレがあると思いますが、多少係数で調整すればいけるかな・・・。(^_^A;

 Sub 二重取り消し線()

 '定数宣言'換算係数
 Const W As Single = 6.28  '列幅に対する係数
 Const H As Single = 1    '行高に対する係数
 Const L As Single = 0.85    '文字数に対する係数

 Application.ScreenUpdating = False
 MyRow = ActiveCell.Row
 MyCol = ActiveCell.Column
 DFW = ActiveCell.ColumnWidth  '元の列幅
 DFH = ActiveCell.RowHeight    '元の行高

 Set MyC = Cells(MyRow, MyCol)
 With MyC
    For i = 1 To MyRow
        MyRH = MyRH + Cells(i, 1).RowHeight
    Next i
        MyRH = MyRH - .RowHeight / 2

    For ii = 1 To MyCol
        MyCW = MyCW + Cells(1, ii).ColumnWidth
    Next ii
        MyCW = MyCW - .ColumnWidth / 2
        MyFS = .Font.Size                'フォントサイズ
        MyHA = .HorizontalAlignment      '横位置
        MyVA = .VerticalAlignment        '縦位置
        .Columns.AutoFit
        .Rows.AutoFit
        MyLo = .ColumnWidth * L          '文字長さ取得
        MyFH = .RowHeight                '文字高さ取得
        Columns(MyCol).ColumnWidth = DFW '元に戻す
        Rows(MyRow).RowHeight = DFH      '元に戻す
    End With

 '----座標位置計算----

 Select Case MyHA
    Case 1
        HStart = MyCW - DFW / 2 '横の始まり（左）
    Case -4108
        HStart = MyCW - MyLo / 2        '（中央）
    Case -4152
        HStart = MyCW + DFW / 2 - MyLo  '（右）
 End Select

 Select Case MyVA
    Case -4160
        VStart = MyRH - DFH / 2 + MyFH / 2 '縦の始まり（上）
    Case -4108
        VStart = MyRH                            '（中央）
    Case -4107
        VStart = MyRH + DFH / 2 - MyFH / 2 '（下）
 End Select

 '----二重線書き込み----

 Set MyS = ActiveSheet
 With MyS.Shapes.AddLine(HStart * W, VStart * H, (HStart + MyLo) * W, VStart * H).Line
    .Style = msoLineThinThin
    .Weight = 3#
 End With
 Application.ScreenUpdating = True
 End Sub
 （川野鮎太郎）

 皆さんマクロで考えるので私も・・・
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Myrng As Range
    Dim Mycenter As Single, Myleft As Single, Myright As Single

    Cancel = True

    Set Myrng = Target
    Mycenter = Myrng.Top + Myrng.Height / 2
    Myleft = Myrng.Left
    Myright = Myrng.Left + Myrng.Width

    With ActiveSheet.Shapes.AddLine(Myleft, Mycenter, Myright, Mycenter).Line
        .Style = msoLineThinThin
        .Weight = 3#
    End With
 End Sub
（ケン）

 おにょ・・・、TopやLeftでアクティブセルの位置が出るんだ(^_^A;
 一個一個足して計算してしまった＿/￣|○ il||li
 （川野鮎太郎）

 あのぅ、、こうやってみるとσ(^◇^;)の品祖ざんす。＿/￣|○ il||li
こりゃほんとに別分野を開拓せにゃ（￣□￣；）！！
（SoulMan）

 今更ながらの今更ですがぁ、、難産でした。
書いたら、消した方がいいかな？っと思いまして。。
シートモジュールに↓これを
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Intersect(Target, Range("A1:D5")) Is Nothing Then Exit Sub
    With Target
        With Me.Shapes.AddLine(.Left, .Top + .Height / 2, .Left + .Width, .Top + .Height / 2)
            .OnAction = "削除"
            .Line.Style = msoLineThinThin
            .Line.Weight = 3#
            .Line.ForeColor.SchemeColor = 12
        End With
    End With
End Sub
標準モジュールにこれを貼り付けてください。
Sub 削除()
Dim MyName As String
    MyName = ActiveSheet.Shapes(Application.Caller).Name
    ActiveSheet.Shapes(MyName).Delete
End Sub
Sub 変色()
Dim MyName As String
    MyName = ActiveSheet.Shapes(Application.Caller).Name
    ActiveSheet.Shapes(MyName).Select
    With Selection
        If .ShapeRange.Line.ForeColor.SchemeColor = 12 Then
            .ShapeRange.Line.ForeColor.SchemeColor = 10
        Else
            .ShapeRange.Line.ForeColor.SchemeColor = 12
        End If
    End With
ActiveCell.Select
End Sub
おまけです。
.OnAction = "削除"
を↓に変更すると
.OnAction = "変色"
色も変わります。
（SoulMan）

エクセルを俳句帳代わりに使っています。　添削の際に取り消し線を使いたいのですが、縦書きの文字をなぞって取消線のボタンをクリックすると、一文字ごとに横線が入ります。　しかたなく、図形の直線を引いていますが、そうすると行がずれたときに線だけがその位置に残ってしまい、たいへん不便です。
縦に取消線を引く方法はないでしょうか。

 それこそ、WORDを使ったらいいのではないですか？
 別に計算するわけではないんですよね？
 表計算ソフトを使っていて、文字列操作の機能に不満をもたれても･･･
 （コナミ）

コメント返信：

[ 一覧(最新更新順) ]

[[20041103121918]] 『二重線を書き込みたい』（ＭＡＴＵ） ページの最後に飛ぶ

[[20041103121918]]　『二重線を書き込みたい』（ＭＡＴＵ）　ページの最後に飛ぶ