色の知識で人生の可能性が広がる!みんなに役立つ色彩検定 >>

取り消し線の入った文字を一気に削除したいと思い、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

教えて!goo グレード

A 回答 (3件)

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
    • good
    • 1
この回答へのお礼

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

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

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


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

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

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

>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だったら何もしない。
その他はそのままのように。

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

ありがとうございます。下記のようにしてみたらすべてのセル文字削除となってしました。
根本が間違っていると思うのですが、何がダメかご教授頂けると幸いです。
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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

人気Q&Aランキング