指定したセルに取り消し線が含まれるかを判別するVBAマクロ

ContainsStrikethrough.vb

Option Explicit

Public Sub Sample()
  If ContainsStrikethrough(Selection) Then
    MsgBox "指定したセル範囲内に取り消し線が含まれるセルがあります。", vbInformation + vbSystemModal
  Else
    MsgBox "指定したセル範囲内に取り消し線が含まれるセルはありません。", vbExclamation + vbSystemModal
  End If
End Sub

'指定したセルに取り消し線が含まれるか判別
Public Function ContainsStrikethrough(ByVal TargetRange As Excel.Range) As Boolean
  Dim rng As Excel.Range
  Dim ret As Boolean
  Dim d As Object, elm As Object
  
  Set d = CreateObject("MSXML2.DOMDocument.6.0")
  For Each rng In TargetRange
    If rng.Font.Strikethrough Then
      ret = True
      Exit For
    Else
      d.async = False
      If d.LoadXML(rng.Value(xlRangeValueXMLSpreadsheet)) Then
        Set elm = d.SelectSingleNode("//*[local-name()='Cell']")
        If Not elm Is Nothing Then
          If elm.SelectNodes("//*[local-name()='S']").Length > 0 Then
            ret = True
            Exit For
          End If
        End If
      End If
    End If
  Next
  ContainsStrikethrough = ret
End Function