取り消し線が入った文字を削除する処理を速くしたい（VBA）

取り消し線の入った文字を一気に削除したいと思い、VBAで下記を実行しようとしましたが、
選択範囲が多いため非常に時間がかかっております。
（ネットで見つけた構文に少し手を加えています。）
速くする方法あれば構文をご教授お願いいたします。

　　Dim lastRow As Long
Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, "K").End(xlUp).Row
Range("K7", Cells(lastRow, "S")).Select
For Each myCell In Selection
textBefore = myCell.Value
textAfter = ""
For i = 1 To Len(textBefore)
If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
textAfter = textAfter & Mid(textBefore, i, 1)
End If
Next i
myCell.Value = textAfter
Next myCell
Application.ScreenUpdating = True

No.1 回答者： taku-9023.ham 回答日時： 2019/07/19 20:02

＞For i = 1 To Len(textBefore)

＞If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
＞textAfter = textAfter & Mid(textBefore, i, 1)
＞End If
＞Next i

その前に条件分岐するようにしてみては？
もし、その文字全体のFont.StrikethroughがFalseだったら何もしない。
その他はそのままのように。

もし、取り消し線が入っているセルの方が多かったら逆でやったらいいと思います。
それ以上の短縮はちょっと思いつきません。
お力になれれば幸いです。

この回答へのお礼

ありがとうございます。下記のようにしてみたらすべてのセル文字削除となってしました。
根本が間違っていると思うのですが、何がダメかご教授頂けると幸いです。
VBA初心者すみません。

Dim lastRow As Long
Dim textBefore as String
Dim textAfter as String
Dim myCell as Range
Dim i As LongApplication.ScreenUpdating = False
lastRow = Cells(Rows.Count, "K").End(xlUp).Row
Range("K7", Cells(lastRow, "S")).Select
For Each myCell In Selection
textBefore = myCell.Value
textAfter = ""
If myCell.Font.Strikethrough = True Then
For i = 1 To Len(textBefore)
If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
textAfter = textAfter & Mid(textBefore, i, 1)
End If
Next i
End If
myCell.Value = textAfter
Next myCell

Application.ScreenUpdating = True

お礼日時：2019/07/20 09:49

No.2 回答者： googoo900 回答日時： 2019/07/20 02:25

コードの最初に以下を追加する。

すべての変数の型宣言を追加することで、若干速くできるはずです。効果は未検証ですがそんなに大きくはないです。
Dim textBefore as String
Dim textAfter as String
Dim myCell as Range
Dim i As Long

この回答へのお礼

ありがとうございます。
設定しましたが、あまり変化はありませんでした。

お礼日時：2019/07/20 09:53

No.3 ベストアンサー 回答者： enunokokoro 回答日時： 2019/07/20 15:03

No.1のお礼にあるmyCell.Font.Strikethrough = Trueだと、削除

されるように書かれていますね。
Next i
myCell.Value = textAfter
この順番が逆にならないと削除されます。

セル内の一部に取り消し線がある文字列のみを対象にする場合は、
上記でのTrueでは判定できないと思います。
If (IsNull(n) = True) Then
このような判定でないと、処理がされません。

処理の速さは別にして、判定処理するものをお礼のマクロに追加を
してみました。


Sub StrikethroughDelete()
Dim lastRow As Long
Dim textBefore As String
Dim textAfter As String
Dim myCell As Range
Dim i As Long
Dim n As Variant
n = Null

Application.ScreenUpdating = False

　lastRow = Cells(Rows.Count, "K").End(xlUp).Row
　Range("K7", Cells(lastRow, "S")).Select

　For Each myCell In Selection
　　textBefore = myCell.Value
　　textAfter = ""
　　n = myCell.Font.Strikethrough

　　　If (IsNull(n) = True) Then
　　　　For i = 1 To Len(textBefore)
　　　　　If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
　　　　　　textAfter = textAfter & Mid(textBefore, i, 1)
　　　　　End If
　　　　Next i
　　　　　myCell.Value = textAfter
　　　　Else
　　　　　If myCell.Font.Strikethrough = True Then
　　　　　　myCell.ClearContents
　　　　End If
　　　End If

　Next myCell

Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございました。
ご教授頂きました内容で処理を速くすることができました。

お礼日時：2019/07/25 16:11