幽霊続きのお話・・・

幽霊続きの話です。
幽霊セルというものがあることを偶然知ってしまいました。

幽霊セルは、セルに画面上表示されない値が入力されているのが原因で以下の3つが挙げられていました。

１．スペースのみのセル
２．空文字列のセル
３．シングルクォーテーションのみのセル

この中で項番２の空文字列のセルは過去に自分も生成してたかもというやつでした。

次のようなIF関数などを使った数式で空文字列を設定している場合に生じるという話だった。
=IF(A1="", "", A1*B1)
この数式では、入力のない行の計算結果に0を表示させないよう、A1セルが空のときにあえて空文字列（""）を設定しています。
このように数式で空文字列を設定したセルをコピーし、別のセルに「値のみ貼り付け」をすると、その空文字列（長さ0の文字列）を値として保持するセルができてしまうという仰天するような話だった。これはこれで何も悪さしないのなら問題ないんだけど・・・
＜悪さの例＞
１．COUNTA関数が実際より多い数になる
２．空白なのにISBLANK関数がFALSEを返す
３．Ctrl+矢印のジャンプで何もないと所で止まる
結局、 目には見えないのに確かにEXCELは何かいると答える、まるで幽霊のようなセルと言えます。
時に、数式や集計を狂わせ、CSVや印刷で大量の空行を吐き出すなどの損害を被ることになります。
そんな幽霊セルを解決するブログに巡り合いました。

2020-02-24　空白なのに空白じゃないセルを空白にしたい
シートの空文字列を除去
空白なのに空白じゃないセルを空白にしたい - シーゴの Excel 研究室

上記のサイトのコード解析をする過程でこれまで、使ったことのなかったコードスニペットが以下になります。
■空白を網掛けにする
Range("C11").Select
Selection.SpecialCells(xlCellTypeBlanks).Select

■PCの画面全体を撮る

Public Sub 全体を撮る()
    keybd_event vbKeySnapshot, 0&, &H1, 0&
    keybd_event vbKeySnapshot, 0&, &H1 Or &H2, 0&
End Sub

■アクティブウィンドウを撮る

Public Sub アクティブ画面を撮る()
    keybd_event &HA4, 0&, &H1, 0& ' &HA4がAltキー、&H1キーを押す
    keybd_event vbKeySnapshot, 0&, &H1, 0& ' vbKeySnapshotがPrtScキー番号は&H2Cらしい
    keybd_event vbKeySnapshot, 0&, &H1 Or &H2, 0& 'PrtScキー &H2でキーを放す
    keybd_event &HA4, 0&, &H1 Or &H2, 0& ' Atlキーを放す
End Sub

■スペースのみの文字列を削除となっているが、結果的に以下の3つすべてを除去することに成功した。
（上記ブログの改変を行いシングルクォーテーションのみのセルのみ除去するようにした）
１．スペースのみのセル
２．空文字列のセル
３．シングルクォーテーションのみのセル

Sub テキスト置換_スペースのみの文字列を削除()

    Dim QMSG As String
    Dim RC
    
    QMSG = "「テキスト置換_スペースのみの文字列を削除」はシート上の"
    QMSG = QMSG & vbLf & "「スペースのみ」を一括除去します。"
    QMSG = QMSG & vbLf & "結果的に「'」のみのセル、空文字も除去します。"
    
    RC = MsgBox(QMSG, vbYesNo, "■シートの「スペースのみ」を除去")
    
    If RC = vbYes Then
    Else
        Exit Sub
    End If
    
    'Dim WS0 As Worksheet
    'Set WS0 = ActiveSheet
    
    Dim WS1 As Worksheet
    
    Set WS1 = Sheets("幽霊セル")
    WS1.Activate
        
    If TypeName(Selection) <> "Range" Then Beep: Exit Sub
    
    Dim rng As Range
    
    Set rng = Intersect(Selection, ActiveSheet.UsedRange)
    
    If rng Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Call rangeTextReplaceAll(rng, "^( |　)+$", "")
    Application.ScreenUpdating = True
    
    Range("C11").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    MsgBox "「スペースのみの文字列を削除」が終了しました！"
    
End Sub

Private Sub rangeTextReplaceAll(rng As Range, rePattern As String, reReplace As String)

    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    
    re.Global = True
    
    re.Pattern = rePattern
    
    Dim col As Range
    
    For Each col In rng.Columns
    
        Dim vals As Variant
        
        Dim preChar As Variant
        ReDim preChar(1 To col.Cells.Count, 1 To 1)
        
        Dim i As Long
        For i = 1 To col.Cells.Count
            If col.Cells(i, 1) <> "" Then
                preChar(i, 1) = col.Cells(i, 1).PrefixCharacter
            End If
        Next
        
        If col.Cells.Count > 1 Then
            vals = col.Formula
        Else
            vals = col.Resize(, 2).Formula
        End If
                
        For i = 1 To col.rows.Count
            If Left(vals(i, 1), 1) <> "=" Then
                vals(i, 1) = re.Replace(vals(i, 1), reReplace)
            End If
        Next
        
        col.Formula = vals
        
        For i = 1 To col.Cells.Count
            If preChar(i, 1) <> "" Then
                col.Cells(i, 1).Value = preChar(i, 1) & vals(i, 1)
            End If
        Next
      
    Next
    
End Sub

■シートにごみが残り、EXCELのサイズが膨れ上がっている場合には
　以下のサブルーチンが使えそう。
　選択範囲外の作成にこんなテニクニックを使うとは何か勉強になった気がした。
　冷静に考えるとわざわざこんなテク使わなくても単純に選択範囲外の作成は
　可能な気がしている。次回紹介することにする。

Sub セルのクリア_選択範囲以外をクリア()

    Dim QMSG As String
    Dim RC
    
    QMSG = "「セルのクリア_選択範囲以外をクリア」はシート上の"
    QMSG = QMSG & vbLf & "「選択範囲以外」を一括除去します。"
    
    RC = MsgBox(QMSG, vbYesNo, "■シートの「選択範囲以外」を除去")
    
    If RC = vbYes Then
    Else
        Exit Sub
    End If
    
    Dim WS1 As Worksheet
    
    Set WS1 = Sheets("幽霊セル")
    WS1.Activate
    
    If TypeName(Selection) <> "Range" Then Beep: Exit Sub
    If Selection.Cells.CountLarge = 1 Then Beep: Exit Sub
    
    Application.ScreenUpdating = False
    
    Dim diff As Range
    
    Set diff = rangeDiff(ActiveSheet.UsedRange, Selection)
    
    If Not diff Is Nothing Then
        diff.Clear
    End If
    
    Application.ScreenUpdating = True
    
End Sub

Private Function rangeDiff(rng1 As Range, rng2 As Range) As Range

    Dim tmp As Range
    
    Set tmp = Intersect(rng1, rng2)
    
    If tmp Is Nothing Then Set rangeDiff = rng1: Exit Function
    
    If tmp.Address = rng1.Address Then Set rangeDiff = Nothing: Exit Function
    
    With ActiveWorkbook.Worksheets.Add
    
        .Range(rng1.Address).Value = 1
        .Range(rng2.Address).Clear
        
        On Error Resume Next
        
        Set rangeDiff = rng1.Worksheet.Range( _
            .Range(rng1.Address).SpecialCells(xlCellTypeConstants).Address)

        On Error GoTo 0
        
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        
    End With
    
End Function