ExcelVBAで取消線が入っている文字列を削除する際に無限ループに陥る

総合スコア17000

Zen_then

2019/02/28 15:18

散々ググってもこの記事にはたどり着くことができませんでした。参考記事を教えていただき、問題点がはっきりして大変助かりました。ありがとうございます！

2019/03/01 01:34 編集

・取消線の文字を削除した文字列(書式なし)を作成し、元の内容から取消線の文字だけ読み飛ばして書式をコピーするこれは私も実装中に視野に入れていたのですが、長さの違う文字列に対して書式を移していくというのが何となく引っかかるというか、インデックスがずれたりしたら面倒・・という理由で見送っていました。実際できたものを見ると、フォントコピーがかなりスッキリしますね。私のサンプルコードでは何度も書式をコピーしていましたが、それが1回で済むのは速度面でも大きなメリットだと思います。「文字を削る」タイミングと「書式を移す」タイミングで別々に取り消し線の判定を行っているだけで、「元が同じで、削る条件も同じ」なので問題ないと思いますし、これも選択肢としてアリだと思いました。

2019/03/01 01:35

やることはシンプルなのでそれほど複雑にはならないですね。ただどうしてもループが2回発生してしまうのが残念です。

行動規範の内容に同意します

ベストアンサー

処理されない原因

まず、処理できない原因はCharactersで取り扱える文字数が256文字までだからです。
257文字以降も取得はできるしエラーにもならないのでわかり難いのですが、257文字以上の文字列を操作しても結果は保障されません。
※フォントの適用など、できるものはできるようです。

というわけで、まず処理されない原因はこれだと思います。

回避策としては、256文字以上のセルは一旦他のセルに256文字分だけ取り出して処理し、結果を連結したうえでフォントを１文字ずつ適用する、といった具合でしょうか。

ループの問題

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

For i = tmpLength To 0 Step -1
    If tmpRange.MergeArea(1).Characters(i, 1).Font.Strikethrough Then
        tmpRange.MergeArea(1).Characters(i, 1).Delete
    End If
Next

といった具合です。
こうすることで、ループの中で文字(例えば10文字中の7文字目)を削っても、それ以降に処理する文字列(6文字目より前)には影響を与えないので、独自にカウンタを取る必要がなくなります。
これにより条件を満たすまでループするDo～Loopではなく、For～Nextの有限ループで記述できるので無限ループのリスクを回避できるというわけです。

参考になれば幸いです。

（追記）

256文字ずつ取り出して処理する方法ですが、かなり面倒なことになってしまいました。
もう少しシンプルにできないものでしょうかね・・。

Sub removeStrikethrough()
    Dim tmpRange As Range
    Dim i, tmpLength As Long
    Dim iCnt As Integer
    Dim iIdx As Integer
    
    Dim cWk1 As Range   '作業用①：256文字ずつ取り出すセル
    Dim cWk2 As Range   '作業用②：処理結果を連結するセル
    Dim cOrg As Range   '作業用③：元の内容を保管するセル
    
    Set cOrg = Cells(1, 1)  '使っていないセル(A1)
    Set cWk1 = Cells(2, 1)  '使っていないセル(A2)
    Set cWk2 = Cells(3, 1)  '使っていないセル(A3)
    
    '速度向上のため処理中の画面更新をOFF
    Me.Application.ScreenUpdating = False
    
    For Each tmpRange In Selection
        
        '結合セルは先頭セルでのみ処理する
        If tmpRange.Address <> tmpRange.MergeArea(1).Address Then Exit For
        
        tmpLength = Len(tmpRange.MergeArea(1).Value)
    
         '元のセルを作業用③セルにコピーする
         tmpRange.Copy cOrg
         '元のセルはクリアする（結果を出力するため）
         tmpRange = ""
        
         '後ろから256文字ずつ取り出すループ
         For iCnt = Int((tmpLength - 1) / 256) To 0 Step -1
             
             '作業用③から①に256文字を転記
             cWk1 = cOrg.Characters(1 + (256 * iCnt), 256).Caption
             
             '作業用③セルから作業用①セルへ書式を反映
             For i = 1 To 256
                 iIdx = i + (256 * iCnt)
                 If iIdx > tmpLength Then Exit For
                 
                 'フォントのコピー
                 Call prcCopyFont(cWk1, i, cOrg.Characters(iIdx, 1).Font)
                 
             Next i
             
             '作業用①セルから取り消し線の文字を削除する
             For i = Len(cWk1) To 0 Step -1
                 If cWk1.Characters(i, 1).Font.Strikethrough Then
                     cWk1.Characters(i, 1).Delete
                 End If
             Next
             
             '元セル（現時点での結果セル）の内容を作業用②セルに出力する
             tmpRange.Copy cWk2
             
             '元セル（現時点での結果セル）に作業用①と作業用②の内容を連結する。
             tmpRange = cWk1.Text & cWk2.Text
             
             '作業用①の書式を反映する
             For iIdx = 1 To Len(cWk1)
                 'フォントのコピー
                 Call prcCopyFont(tmpRange, iIdx, cWk1.Characters(iIdx, 1).Font)
             Next
             '作業用②の書式を反映する
             For iIdx = 1 To Len(cWk2)
                 'フォントのコピー
                 Call prcCopyFont(tmpRange, iIdx + Len(cWk1), cWk2.Characters(iIdx, 1).Font)
             Next
         Next iCnt
         
    Next
    
    cOrg.Clear
    cWk1.Clear
    cWk2.Clear
    
    '画面更新をON
    Me.Application.ScreenUpdating = True
    
End Sub

'フォントをコピーする関数
Sub prcCopyFont(ByRef vCell As Range, ByVal vIndex As Integer, ByVal vFont As Font)
    
    With vCell.Characters(vIndex, 1).Font
        .Bold = vFont.Bold
        .Color = vFont.Color
        .Italic = vFont.Italic
        .Name = vFont.Name
        .Size = vFont.Size
        .Underline = vFont.Underline
        .Strikethrough = vFont.Strikethrough
    End With

End Sub

投稿2019/02/28 01:32

編集2019/02/28 05:41

総合スコア3020

2019/02/28 01:33

逆順ループの提案までttyp03さんと内容ほぼ被りでした。。

2019/02/28 05:44 編集

256文字ずつ切り出して処理する方法を追記してみましたが、文字単位の書式コピーが面倒なうえにかなり重い処理になってしまいますね。作業用に、使ってないセルを３つも利用してますし。一応、参考までにということで。

2019/02/28 06:23

おー、すごいです。けどかなり重いですね。オブジェクトのディープコピーができれば楽なんでしょうけどなかなか厳しいですね。

2019/02/28 07:13 編集

そうなんです。 `CellA.Characters(1,0).Insert (CellB.Characters(1,256))`みたいなかんじで、CharactersからCharactersへ書式付きで切り貼りできればラクなんですが。。

Zen_then

2019/02/28 15:11

ありがとうございます！ループの組み方のご指摘から代替案の提示まで本当に勉強になりました。ワーク用セルを3つ使用しないといけない点は、空きセルの位置をどこか決める必要がある点では確かに悩ましいところですね。自身の環境に合わせて実装を検討させていただきますm(_ _)m

2019/03/01 00:46

もう解決されていますが、私の方でもコードを書いてみました。ワーク用セルは必須ですが、私の案ではシートを一時的に作成することで回避しています。参考まで。

行動規範の内容に同意します

Strikethrough=Falseにしてみて下さい。

VBA
1        Do While i <= tmpLength
2            If tmpRange.MergeArea(1).Characters(i, 1).Font.Strikethrough Then
3                tmpRange.MergeArea(1).Characters(i, 1).Font.Strikethrough = False
4                tmpRange.MergeArea(1).Characters(i, 1).Text = ""
5            Else
6                i = i + 1
7            End If
8            tmpLength = Len(tmpRange.MergeArea(1).Value)
9        Loop

Deleteではなく空文字で置き換えると上手く動作しました。

投稿2019/02/28 01:31

編集2019/02/28 01:58

総合スコア25430

2019/02/28 15:56 編集

無限ループはしなくなるけど、Deleteで文字が削除されませんね・・しかも、かなり時間が掛かってしまう。

2019/02/28 15:56 編集

空文字での置き換えに修正しました。

Zen_then

2019/02/28 15:14

回答ありがとうございます！私の環境で試してみましたが残念ながら文字が削除されませんでした。結果こそ伴いませんでしたが、ソースを見たときに思わず「なるほど！」と感嘆しました^^