勉強ブログ

'呼び出し元
'内容＝取り消し線のあるセルの値をクリアし、その行を黄色で塗る
'対象＝Range(Cells(1, 1), Cells(1000, 100))
'空白行で取り消し線のあったセルの塗りつぶしは行わない
Function clr_value()
Dim tst As Range

For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
Call del_strkthr_range(tst)
Next



For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
tst.Value = del_strkthr_char(tst)
Next

MsgBox "End"
End Function




'呼び出し先
Function del_strkthr_range(cell As Range)
If cell.Font.Strikethrough = True And cell.Value <> "" Then
cell.Value = ""
If WorksheetFunction.CountA(Rows(cell.Row)) = 0 Then
Rows(cell.Row).Interior.ColorIndex = 6
Else
End If
Else
End If


End Function


'呼び出し先
Function del_strkthr_char(cell As Range)
Dim count As Integer
Dim i As Integer
Dim char As Characters
Dim result As String
count = Len(cell.Text)
For i = 1 To count
Set char = cell.Characters(i, 1)
If Not char.Font.Strikethrough Then
result = result + char.Text
End If
Next
del_strkthr_char = result
End Function