EXCEL VBA 取り消し線（文字飾り・Strikethroughプロパティ・セルの書式設定）

EXCEL VBA 取り消し線（文字飾り・Strikethroughプロパティ・セルの書式設定）

'
'
Sub Strikethrough01() '取り消し線を設定

    Range("A1").Font.Strikethrough = True

End Sub
'

'
'
Sub Strikethrough02() '取り消し線を解除

    Range("A1").Font.Strikethrough = False

End Sub
'

EXCEL VBA 取り消し線（文字飾り・Strikethroughプロパティ）※取り消しを設定/解除

●　サンプルプログラム①Ａパターン

'
'
Sub Strikethrough10A()  '取り消しを一括設定/解除（Aパータン）

   Dim Ans As Boolean  '取得する変数を設定（Boolean：TrueとFalseを格納）
        
    Ans = Range("A1:C3").Font.Strikethrough  'セル（A1：C3）の範囲から取り消し線の設定値を取得（Ans）します。
                                            '（取り消し線がTrueは、設定済・Falseは、未設定）
                                            
    If Ans = True Then  '取得した取り消し線の取得値を判定します。
            Range("A1：C3").Font.Strikethrough = False  'Trueの場合は、取り消し線を解除します（False）
         Else
            Range("A1：C3").Font.Strikethrough = True  'Falseの場合は、取り消し線を設定します（True）
    End If

End Sub
'

●　サンプルプログラム①Ｂパターン

'
'
Sub Strikethrough10B()  '取り消しを一括設定/解除（Bパターン）

    Dim Ans As Boolean '取得する変数を設定（Boolean：TrueとFalseを格納）
    
    Ans = Not Range("A1：C3").Font.Strikethrough
    'セル（A1：C3）の範囲から取り消し線の逆の設定値を取得（Ans）します。
    'Falseの場合は、Trueを返します。
    'Trueの場合は、Falseを返します。
    
    Range("A1：C3").Font.Strikethrough = Ans
    'セル（A1:C3）の範囲へ取り消し線を設定又は、解除を設定します。
    
End Sub
'

EXCEL VBA 取り消し線（文字飾り・Strikethroughプロパティ）※ダブルクリックで取り消し線を引く・更にダブルクリックで取り消し線を解除

'
'
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)


    Dim Ans As Boolean '取得する変数を設定（Boolean：TrueとFalseを格納）
    
    Ans = Not ActiveCell.Font.Strikethrough
    '選択セルの取り消し線の設定値の逆を取得（Ans）します。
    'Falseの場合は、Trueを返します。
    'Trueの場合は、Falseを返します。
    
    ActiveCell.Font.Strikethrough = Ans
    '選択セルの取り消し線を設定又は、解除を設定します。

End Sub
'
'

EXCEL VBA 取り消し線（文字飾り・Strikethroughプロパティ）※条件に一致するデータに対して取り消し線を引く

'
'
Sub Strikethrough30() '条件に一致した該当データに対して取り消し線を引く

    Dim ws01, ws02 As Worksheet
    Dim I, lRow, mRow, xRow As Long
  
    Set ws01 = Worksheets("退職リスト")
    Set ws02 = Worksheets("社員住所録")
 
    ws02.Cells.Font.Strikethrough = False 'シート「社員住所録」
    
    lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'シート「退職リスト」B列の最終行を取得します。
    xRow = ws02.Cells(Rows.Count, "B").End(xlUp).Row ' シート「社員住所録」B列の最終行を取得します。
    
    For I = 2 To lRow 'シート「退職リスト」のB列最終行まで繰り返します。
    
        mRow = 0
        On Error Resume Next  'エラーが発生を無視します。
        mRow = WorksheetFunction.Match(ws01.Cells(I, "B"), ws02.Range("B2:B" & xRow), 0) + 1
        'シート「退職リスト」から該当社員をシート「社員住所録」から探し、該当行を取得します。
        On Error GoTo 0
        
        If mRow <> 0 Then  '該当社員がいる場合は、該当する行番号があるか確認します。
            ws02.Range("A" & mRow & ":E" & mRow).Font.Strikethrough = True
            '該当するデータにA列～E列まで取り消し線を引きます。
                Else
            MsgBox "社員住所録には、該当するデータ【" & ws01.Cells(I, "B") & "】がありません。"
            '行番号が０の場合は、該当するデータが無いのでメッセージを表示します。
        End If
    Next I
    
    ws02.Activate  'シート「社員住所録」をアクティブにします。（前面表示）
    
End Sub
'
'