複数エクセルファイルの取消文字列を一括削除するマクロ

仕様書の変更箇所を分かりやすくするために、変更履歴、取消線、文字色などが活用されています。やがて、文字色を統一し、変更履歴や取消線で消された文字を削除し、納品物に仕上げます。

今回ご紹介するマクロは
・セルの全部、または一部が取消線でマークされている文字列を削除します。
・処理結果を記録します。

画面はこうなります。

1.処理開始画面
処理対象ファイルを検索してから、一括削除する流れで操作します。
取消線でマークされた文字列を一セルずつ検索するので、セルの範囲を指定して、スピードアップをはかります。

2.処理結果画面

下図６列で処理結果を把握します。

ソースはこうなります。

'***************************************************
'画面の「取消文字を一括削除」ボタンから呼び出される
'***************************************************
Sub DelStrikeOutWords()

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strFile As String
   
    Dim intRow As Integer
    Dim intLastRow As Integer
   
    Dim intCount As Integer
    Dim celCell As Variant

    Dim chaChar As Characters
    Dim strResult As String
    Dim strDelWord As String
    Dim strRange As String

    If ThisWorkbook.Sheets(1).Range("D10").Value = "" Then Exit Sub

    '最終行を求める
    intLastRow = ThisWorkbook.Sheets(1).Range("D9").End(xlDown).Row

    '画面更新を無効にする
    Application.ScreenUpdating = False

    '削除処理の範囲
    strRange = ThisWorkbook.Sheets(1).Range("S2").Value

    intRow = 1
    ThisWorkbook.Sheets("List").Cells.Clear
    ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = "処理結果一覧"

    intRow = 2
    ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = "削除前"
    ThisWorkbook.Sheets("List").Cells(intRow, 2).Value = "削除文字"
    ThisWorkbook.Sheets("List").Cells(intRow, 3).Value = "削除後"
    ThisWorkbook.Sheets("List").Cells(intRow, 4).Value = "セル"
    ThisWorkbook.Sheets("List").Cells(intRow, 5).Value = "シート"
    ThisWorkbook.Sheets("List").Cells(intRow, 6).Value = "ファイル"


    'メッセージ表示を無効にする
    Application.DisplayAlerts = False

    'ファイル毎の処理
    For i = 10 To intLastRow
   
        strFile = ThisWorkbook.Sheets(1).Cells(i, 4).Value

        If Right(strFile, 3) = "xls" Or Right(strFile, 4) = "xlsx" Then

            'ファイルをセットする
            Set objBook = Application.Workbooks.Open(strFile)
       
            'シート毎の処理
            For Each objSheet In objBook.Sheets
         
                'セル毎の処理
                For Each celCell In objSheet.Range(strRange)

              　　 '数字だと、エラーになるので、文字列だけ処理する
                    If VarType(celCell.Value) = vbString Then
           
                      intCount = Len(celCell)
                      strResult = ""
                      strDelWord = ""
             
                      For j = 1 To intCount
                     
                          Set chaChar = celCell.Characters(j, 1)
                     
                          If chaChar.Font.Strikethrough Then
                       
                             strDelWord = strDelWord + chaChar.Text
                           
                          Else
                       
                            strResult = strResult + chaChar.Text
                         
                          End If
                     
                      Next j
                 
                      If Len(strDelWord) > 0 Then
                     
                          '削除対象文字の一覧を作成する
                          intRow = intRow + 1
                          ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = celCell.Value
                          ThisWorkbook.Sheets("List").Cells(intRow, 2).Value = Trim(strDelWord)
                          ThisWorkbook.Sheets("List").Cells(intRow, 3).Value = Trim(strResult)
                          ThisWorkbook.Sheets("List").Cells(intRow, 4).Value = celCell.Row _
                                                               & "行" & celCell.Column & "列"
                          ThisWorkbook.Sheets("List").Cells(intRow, 5).Value = objSheet.Name
                          ThisWorkbook.Sheets("List").Cells(intRow, 6).Value = objBook.Name
                     
                          '削除後の文字をセットする
                          celCell.Value = Trim(strResult)
                 
                      End If
                 
                    End If
           
                Next celCell
       
            Next objSheet
       
            'ファイルクローズ
            objBook.Close savechanges:=True
               
        End If
       
    Next i

    'メッセージ表示を有効にする
    Application.DisplayAlerts = True

    '画面更新を有効に戻す
    Application.ScreenUpdating = True

    'シート処理結果をアクティブにする
    ThisWorkbook.Sheets("List").Activate

    ' 処理完了(結果表示)
    MsgBox "処理が完了しました。"

End Sub

-----------------------

以上