質問するログイン新規登録

回答編集履歴

1

追記

2019/03/01 00:43

投稿

ttyp03
ttyp03

スコア17002

answer CHANGED
@@ -27,4 +27,73 @@
27
27
  Next tmpRange
28
28
  End Sub
29
29
 
30
+ ```
31
+
32
+ 追記
33
+ なんか気になって寝ながらコードを考えたので書いてみました。
34
+ 参考まで。
35
+ ```VBA
36
+ Public Sub removeStrikethrough()
37
+
38
+ Debug.Print Now
39
+
40
+ Application.DisplayAlerts = False
41
+
42
+ Dim tmpRange As Range
43
+ Dim i, j, tmpLength As Long
44
+
45
+ Dim ash As Worksheet ' セルが選択されているシート
46
+ Dim wsh As Worksheet ' 作業用シート
47
+ Dim wrg As Range ' 作業用セル
48
+
49
+ Set ash = ActiveSheet
50
+ Set wsh = ActiveWorkbook.Worksheets.Add
51
+ Set wrg = wsh.Cells(1, 1)
52
+ ash.Select
53
+
54
+ For Each tmpRange In Selection
55
+
56
+ tmpLength = Len(tmpRange.MergeArea(1).Value)
57
+
58
+ ' 対象セルを作業用セルにコピー
59
+ tmpRange.Copy wrg
60
+
61
+ ' 取消し線以外の文字を収集
62
+ tmpv = ""
63
+ For i = 1 To tmpLength
64
+ With wrg.Characters(i, 1)
65
+ If Not .Font.Strikethrough Then
66
+ tmpv = tmpv & .Caption
67
+ End If
68
+ End With
69
+ Next
70
+
71
+ ' 取消し線以外の文字で更新
72
+ tmpRange.Value = tmpv
73
+
74
+ ' 取消し線以外の文字のフォント情報をコピー
75
+ j = 1
76
+ For i = 1 To tmpLength
77
+ With wrg.Characters(i, 1)
78
+ If Not .Font.Strikethrough Then
79
+ tmpRange.Characters(j, 1).Font.Bold = .Font.Bold
80
+ tmpRange.Characters(j, 1).Font.Color = .Font.Color
81
+ tmpRange.Characters(j, 1).Font.ColorIndex = .Font.ColorIndex
82
+ tmpRange.Characters(j, 1).Font.FontStyle = .Font.FontStyle
83
+ tmpRange.Characters(j, 1).Font.Italic = .Font.Italic
84
+ tmpRange.Characters(j, 1).Font.Size = .Font.Size
85
+ tmpRange.Characters(j, 1).Font.Underline = .Font.Underline
86
+ j = j + 1
87
+ End If
88
+ End With
89
+ Next
90
+ Next tmpRange
91
+
92
+ wsh.Delete
93
+
94
+ Application.DisplayAlerts = True
95
+
96
+ Debug.Print Now
97
+
98
+ End Sub
30
99
  ```