回答編集履歴

2

ついき

2019/02/28 05:41

投稿

jawa
jawa

スコア3020

test CHANGED
@@ -53,3 +53,207 @@
53
53
 
54
54
 
55
55
  参考になれば幸いです。
56
+
57
+
58
+
59
+ (追記)
60
+
61
+ ---
62
+
63
+ 256文字ずつ取り出して処理する方法ですが、かなり面倒なことになってしまいました。
64
+
65
+ もう少しシンプルにできないものでしょうかね・・。
66
+
67
+ ```
68
+
69
+ Sub removeStrikethrough()
70
+
71
+ Dim tmpRange As Range
72
+
73
+ Dim i, tmpLength As Long
74
+
75
+ Dim iCnt As Integer
76
+
77
+ Dim iIdx As Integer
78
+
79
+
80
+
81
+ Dim cWk1 As Range '作業用①:256文字ずつ取り出すセル
82
+
83
+ Dim cWk2 As Range '作業用②:処理結果を連結するセル
84
+
85
+ Dim cOrg As Range '作業用③:元の内容を保管するセル
86
+
87
+
88
+
89
+ Set cOrg = Cells(1, 1) '使っていないセル(A1)
90
+
91
+ Set cWk1 = Cells(2, 1) '使っていないセル(A2)
92
+
93
+ Set cWk2 = Cells(3, 1) '使っていないセル(A3)
94
+
95
+
96
+
97
+ '速度向上のため処理中の画面更新をOFF
98
+
99
+ Me.Application.ScreenUpdating = False
100
+
101
+
102
+
103
+ For Each tmpRange In Selection
104
+
105
+
106
+
107
+ '結合セルは先頭セルでのみ処理する
108
+
109
+ If tmpRange.Address <> tmpRange.MergeArea(1).Address Then Exit For
110
+
111
+
112
+
113
+ tmpLength = Len(tmpRange.MergeArea(1).Value)
114
+
115
+
116
+
117
+ '元のセルを作業用③セルにコピーする
118
+
119
+ tmpRange.Copy cOrg
120
+
121
+ '元のセルはクリアする(結果を出力するため)
122
+
123
+ tmpRange = ""
124
+
125
+
126
+
127
+ '後ろから256文字ずつ取り出すループ
128
+
129
+ For iCnt = Int((tmpLength - 1) / 256) To 0 Step -1
130
+
131
+
132
+
133
+ '作業用③から①に256文字を転記
134
+
135
+ cWk1 = cOrg.Characters(1 + (256 * iCnt), 256).Caption
136
+
137
+
138
+
139
+ '作業用③セルから作業用①セルへ書式を反映
140
+
141
+ For i = 1 To 256
142
+
143
+ iIdx = i + (256 * iCnt)
144
+
145
+ If iIdx > tmpLength Then Exit For
146
+
147
+
148
+
149
+ 'フォントのコピー
150
+
151
+ Call prcCopyFont(cWk1, i, cOrg.Characters(iIdx, 1).Font)
152
+
153
+
154
+
155
+ Next i
156
+
157
+
158
+
159
+ '作業用①セルから取り消し線の文字を削除する
160
+
161
+ For i = Len(cWk1) To 0 Step -1
162
+
163
+ If cWk1.Characters(i, 1).Font.Strikethrough Then
164
+
165
+ cWk1.Characters(i, 1).Delete
166
+
167
+ End If
168
+
169
+ Next
170
+
171
+
172
+
173
+ '元セル(現時点での結果セル)の内容を作業用②セルに出力する
174
+
175
+ tmpRange.Copy cWk2
176
+
177
+
178
+
179
+ '元セル(現時点での結果セル)に作業用①と作業用②の内容を連結する。
180
+
181
+ tmpRange = cWk1.Text & cWk2.Text
182
+
183
+
184
+
185
+ '作業用①の書式を反映する
186
+
187
+ For iIdx = 1 To Len(cWk1)
188
+
189
+ 'フォントのコピー
190
+
191
+ Call prcCopyFont(tmpRange, iIdx, cWk1.Characters(iIdx, 1).Font)
192
+
193
+ Next
194
+
195
+ '作業用②の書式を反映する
196
+
197
+ For iIdx = 1 To Len(cWk2)
198
+
199
+ 'フォントのコピー
200
+
201
+ Call prcCopyFont(tmpRange, iIdx + Len(cWk1), cWk2.Characters(iIdx, 1).Font)
202
+
203
+ Next
204
+
205
+ Next iCnt
206
+
207
+
208
+
209
+ Next
210
+
211
+
212
+
213
+ cOrg.Clear
214
+
215
+ cWk1.Clear
216
+
217
+ cWk2.Clear
218
+
219
+
220
+
221
+ '画面更新をON
222
+
223
+ Me.Application.ScreenUpdating = True
224
+
225
+
226
+
227
+ End Sub
228
+
229
+
230
+
231
+ 'フォントをコピーする関数
232
+
233
+ Sub prcCopyFont(ByRef vCell As Range, ByVal vIndex As Integer, ByVal vFont As Font)
234
+
235
+
236
+
237
+ With vCell.Characters(vIndex, 1).Font
238
+
239
+ .Bold = vFont.Bold
240
+
241
+ .Color = vFont.Color
242
+
243
+ .Italic = vFont.Italic
244
+
245
+ .Name = vFont.Name
246
+
247
+ .Size = vFont.Size
248
+
249
+ .Underline = vFont.Underline
250
+
251
+ .Strikethrough = vFont.Strikethrough
252
+
253
+ End With
254
+
255
+
256
+
257
+ End Sub
258
+
259
+ ```

1

しゅうせい

2019/02/28 05:41

投稿

jawa
jawa

スコア3020

test CHANGED
@@ -22,7 +22,9 @@
22
22
 
23
23
  ---
24
24
 
25
- もうひとつ、これはテクニックになるのですが、今回のように「文字を削除していく」とか「行を削除していく」といったように「対象を削っていくループ処理」では、ループを逆順回した方処理が安全かつ楽な処理になります。
25
+ もうひとつ、これはテクニックになるのですが、今回のように「文字を削除していく」とか「行を削除していく」といったように「対象を削っていくループ処理」を前方から順に処理していくと、ループをしていく中対象のインデックスずれていくことになります。
26
+
27
+ このような場合は、ループを逆順で回した方が安全かつ楽なコーディングで処理できます。
26
28
 
27
29
  今回の場合でいうと、逆順ループにしていれば、少なくとも無限ループに陥ることはありませんでした。
28
30