取り消し線の文字を削除するには
Excelの資料の修正を繰り返していく中で、履歴として取り消し線で残している場合があります。
この取り消し線の部分をもう不要だからと削除することもあります。削除前後はこんな感じです。
削除前（「竣工」という取り消し線になっている文字を削除する）
削除後
手作業の場合は以下のような手順になります。
- セルを選択する。
- 取り消し線文字部分にカーソルを当てる。
- 取り消し線の文字部分を削除する。
１か所程度なら大したことありませんが、あまりにも多いと時間が掛かって仕方ありません。面倒です。
そこで、取り消し線の文字列を一括で削除する方法を紹介します。簡単な方法と複雑な方法の２つを紹介します。
簡単な方法のソースコード
以下のコードは選択しているセル範囲を１セルずつ処理します。セルの文字列を１文字ずつ取消線が設定されてあるかを確認し、設定されていればCharacters.Deleteメソッドでその文字を削除します。対象の文字を削除するだけのため、他の文字の書式には影響がありません。また、取消線がないセルで実行しても問題ありません。
実行方法は、セルを選択して実行するだけです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
Sub DeleteStrikethrough() Dim r As Range '// セル '// 選択セル範囲をループ For Each r In Selection Dim i As Integer: i = 1 '// ループカウンタ Dim iLen As Integer: iLen = Len(r.Value) '// 文字列長 Dim c As Characters '// 文字列の1文字のCharacterオブジェクト '// セルの文字数ループ Do '// 終端に達した場合 If i > iLen Then '// ループを抜ける Exit Do End If '// 1文字をCharactersオブジェクトで取得 Set c = r.Characters(i, 1) '// 取消線の場合 If c.Font.Strikethrough = True Then '// 取消線が設定されている文字を削除 c.Delete '// 1文字削除されたので文字列長を減らす iLen = iLen - 1 '// 取消線ではない場合 Else '// ループカウンタを加算 i = i + 1 End If Loop Next End Sub |
複雑な方法のソースコード
簡単な方法の通り、Characters.Deleteメソッドを使えば対象の文字を削除できます。以下の方法はFontオブジェクトがどのようなプロパティで構成されているかが分かりますが、ただの参考です。実際に使う場合は上の簡単な方法のをお勧めします。
Fontオブジェクト用の構造体
メインのソースコードではFontオブジェクトの各プロパティの保持と再設定を行っています。以下のユーザー定義型（構造体）のST_FONTはそのために利用します。
Fontオブジェクトをそのまま使えればそれがいいのですが、セルの文字列が書き換わると保持していたFontオブジェクトも変わってしまうという特性がVBAにはあります。VBAにはオブジェクト変数にディープコピーの概念（コピー元が変更してもコピー先に影響がないコピー方式）がないため構造体で代用しています。
構造体の各変数はFontオブジェクトの各プロパティを同じ名前と型にしています。この構造体は後述のメインコードと同じ標準モジュール等でモジュールの一番上あたりに配置してください。Option Explicitの直後あたりです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
Type ST_FONT Background As Long Bold As Boolean Color As Double ColorIndex As Long FontStyle As String Italic As Boolean Name As String OutlineFont As Boolean Shadow As Boolean Size As Double Strikethrough As Boolean Subscript As Boolean Superscript As Boolean ThemeColor As Variant ThemeFont As XlThemeFont TintAndShade As Double Underline As Long End Type |
メインコード
以下は対象のセルの文字列から取り消し線部分を除去する関数です。
取り消し線の部分を削除するだけならStrikethroughプロパティがTrueの文字だけを連結すればいいのですが、それだと問題が発生します。
問題とは、セルの文字列が再設定（再入力）するとフォントの設定がクリアされてしまう点です。
そこで、ちょっとコードが長くなってしまいますが、セルの１文字ずつのフォントを再設定するための処理を入れています。
処理概要は以下になります。
- セルを１文字ずつ取得。
- 取得した文字が取り消し線が設定されているか確認。
- 取り消し線が設定されていなければ残す。その際のその文字のフォントの各プロパティを保持しておく。
- 取り消し線を除いた文字列をセルに再設定する。
- 再設定後に一文字ずつフォントの各プロパティを再設定する。
なお、構造体には存在していますが使用する必要がないためBackground、Bold、ColorIndex、Italicプロパティは使用していません。
FontオブジェクトのBackgroundプロパティとThemeColorプロパティの取得と設定をコメントにしていますが、使わないので消しています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
Sub DeleteStrikethrough(r As Range) On Error Resume Next Dim i As Long '// 文字列長ループカウンタ Dim iLen As Long '// セル文字列長 Dim c As Characters '// 文字列のCharactersオブジェクト Dim f As Font '// 1文字ごとのFontオブジェクト Dim fAr() As ST_FONT '// Fontオブジェクト設定値保持用の構造体配列 Dim s As String '// 取り消し線除去済みの文字列 Dim iFont As Long '// Fontオブジェクト設定用配列のインデックス '// セル未設定時は処理終了 If (r.Value = "") Then Exit Sub End If iFont = 0 iLen = Len(r.Value) ReDim fAr(iLen) '// セル文字列を１文字ずつループ For i = 1 To iLen '// 1文字分のCharactersオブジェクトを取得 Set c = r.Characters(i, 1) '// Fontオブジェクトを取得 Set f = c.Font '// 対象の１文字に取り消し線が設定されていない場合 If (f.Strikethrough = False) Then '// 取り消し線未設定の文字列を取得 s = s & c.Text '// Fontオブジェクトの各プロパティを保持 fAr(iFont).Name = f.Name fAr(iFont).FontStyle = f.FontStyle fAr(iFont).Size = f.Size fAr(iFont).Strikethrough = f.Strikethrough fAr(iFont).Superscript = f.Superscript fAr(iFont).Subscript = f.Subscript fAr(iFont).OutlineFont = f.OutlineFont fAr(iFont).Shadow = f.Shadow fAr(iFont).Underline = f.Underline fAr(iFont).ThemeColor = f.ThemeColor fAr(iFont).Color = f.Color fAr(iFont).TintAndShade = f.TintAndShade fAr(iFont).ThemeFont = f.ThemeFont iFont = iFont + 1 End If Next '// 取り消し線を除いた文字列をセルに設定 r.FormulaR1C1 = s '// 再度セルの文字列長を取得 iLen = Len(s) '// 取り消し線を除いた文字列を１文字ずつループ For i = 1 To iLen '// 1文字分のFontオブジェクトを再設定のため取得 Set f = r.Characters(Start:=i, Length:=1).Font '// インデックス取得 iFont = i - 1 '// Fontオブジェクトの各プロパティを保持しておいた値で再設定 f.Name = fAr(iFont).Name f.FontStyle = fAr(iFont).FontStyle f.Size = fAr(iFont).Size f.Strikethrough = fAr(iFont).Strikethrough f.Superscript = fAr(iFont).Superscript f.Subscript = fAr(iFont).Subscript f.OutlineFont = fAr(iFont).OutlineFont f.Shadow = fAr(iFont).Shadow f.Underline = fAr(iFont).Underline f.ThemeColor = fAr(iFont).ThemeColor f.Color = fAr(iFont).Color f.TintAndShade = fAr(iFont).TintAndShade f.ThemeFont = fAr(iFont).ThemeFont Next End Sub |
使い方
いくつかのパターンの使い方を紹介します。
1. 指定セルから取り消し線を除く
A2セルから取り消し線を除くためのコードです。
引数にA2セルのRangeオブジェクトを渡しているだけです。
|
1 2 3 4 5 |
Sub DeleteStrikethroughTest() Dim r As Range Call DeleteStrikethrough(Range("A2")) End Sub |
実行前
実行後
2. 選択セルから取り消し線を除く
選択セル範囲の各セルから取り消し線を除くためのコードです。
選択セル範囲をループして１セルずつRangeオブジェクトとして処理しています。
選択セル範囲に空白セルや取り消し線がないセルが存在しても問題ありません。
|
1 2 3 4 5 6 7 |
Sub DeleteStrikethroughMultiCellTest() Dim r As Range For Each r In Selection Call DeleteStrikethrough(r) Next End Sub |
3. アクティブシートの全セルから取り消し線を除く
アクティブシートの全セルから取り消し線を除くためのコードです。
全セルを対象とすると処理時間がかかるため、UsedRangeプロパティで入力されているセル範囲を対象としています。
|
1 2 3 4 5 6 7 |
Sub DeleteStrikethroughMultiCellTest2() Dim r As Range For Each r In ActiveSheet.UsedRange Call DeleteStrikethrough(r) Next End Sub |
4. 全シートから取り消し線を除く
全シートから取り消し線を除くコードです。
上のコードにシートのループを追加しているだけです。
|
1 2 3 4 5 6 7 8 9 10 |
Sub DeleteStrikethroughMultiCellTest3() Dim r As Range Dim sht As Worksheet For Each sht In Worksheets For Each r In sht.UsedRange Call DeleteStrikethrough(r) Next Next End Sub |