56本目：数式内の自身のシート名を消す

出題：数式内の自身のシート名を消す

#VBA100本ノック 56本目
数式に自身のシート名が入っていると数式が長く、並べ替えが上手く出来ない等々何かと邪魔です。
そこで全シートの全数式内での自身のシート参照を消してください。
=自身のシート!C2… → =C2…
※シート名に記号が使われている場合を考慮。
※串刺し計算は置換しません。

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック056：数式内の自身のシート名を消す
Sub 全シートの自シート参照式を消去する()

    Dim シート As Worksheet
    For Each シート In ActiveWorkbook.Worksheets
        Call 自シート参照式を消去する(シート)
    Next

End Sub

Sub 自シート参照式を消去する(ws対象シート As Worksheet)

    ' Evaluate関数を正しく動かすためにActiveにしてから実行
    ws対象シート.Activate

    ' シート名!または'シート名'!を検索
    Dim 自シート参照式 As String: 自シート参照式 = ws対象シート.Name & "!"
    Dim 自シート参照式_SQ有 As String: 自シート参照式_SQ有 = "'" & ws対象シート.Name & "'!"

    ' 数式セルをループ
    Dim 数式セル As Range
    For Each 数式セル In ws対象シート.UsedRange
        If 数式セル.HasFormula Then

            ' まずシングルクォートありを検索（これは発見した時点で置換）
            If InStr(数式セル.Formula, 自シート参照式_SQ有) > 0 Then
                数式セル.Formula = Replace(数式セル.Formula, 自シート参照式_SQ有, "")

            ' シングルクォートなしを検索（これは発見してもシート名が後方一致しただけの可能性あり）
            ElseIf InStr(数式セル.Formula, 自シート参照式) > 0 Then

                ' シート名!を'シート名'!に変えて数式をEvaluate関数で実行してみる。
                ' 本当に第2シートを参照していれば問題なく動いて同じ値を返す
                ' データ2025! というシートが2025!で引っかかってしまっているだけの場合は、
                ' データ'2025'!という参照式になってしまいエラーとなる
                ' この判定で串刺し計算式も置換対象外となる

                ' 元からエラーが出ている場合は、Evaluateの結果が同じエラーになったら置換
                If IsError(数式セル.Value) Then
                    If 数式セル.Value = Evaluate(Replace(数式セル.Formula, 自シート参照式, 自シート参照式_SQ有)) Then
                        数式セル.Formula = Replace(数式セル.Formula, 自シート参照式, "")
                    End If

                ' 元のセルがエラーでない場合は、Evaluateの結果がエラーになっていなければ置換
                Else
                    If IsError(Evaluate(Replace(数式セル.Formula, 自シート参照式, 自シート参照式_SQ有))) = False Then
                        数式セル.Formula = Replace(数式セル.Formula, 自シート参照式, "")
                    End If

                End If
            End If

        End If
    Next

End Sub

解説

自シート名!A1をA1に置換する問題です。

これはブログ内でも便利マクロとして紹介した処理ですね。

アクティブシートにこの処理を実行するマクロを持っておくと便利ですので、
本問を解くついでにリボンやツールバーに登録してみてください。

肝心のコードについて、基本はReplace関数で置換すればよいですが、

• シート名に()などの記号があるとシングルクォートが使われる
• 「テストシート!」と「シート!」があるときは単にシート!で置換できない

この2点に気を付ける必要があります。

「シート名を記号付きに変えてから置換する」という方法もありますが、
シート名を変えて予期せぬエラーが出ると厄介なのでしっかり分岐しました。

シート名の後方一致問題については、Evaluateメソッドを使用して判定しました。

丁寧にコメントを書いてありますので読み解いてみてください。

Dictionaryを使用した高速コード

問題の解答としては上記のコードで十分と思いますが、
実用する場合は速度にも気を使いたいところです。

そもそも1セルずつの変更ではセル数が多いとだいぶ遅くなりますし、
数式の再計算が置換ごとに走ってしまうためさらに遅くなります。

この解決策として、同じ数式を持つセル範囲をひとつのRangeオブジェクトにまとめ、
Formulaの代入を一括で行うコードも作成しました。

数式をKeyとし、その数式を持つ範囲をItemに入れたDictionaryを使用しています。

数万行データの各列に同一の数式が入っている場合は、
前述のコードに比べて千倍以上の速度が出せることもよくあります。

便利マクロとして登録する場合はこちらのコードをご利用ください。

' ノックの解答はこちら
Sub 全シートの自シート参照式を消去する()

    Dim シート As Worksheet
    For Each シート In ActiveWorkbook.Worksheets
        Call 自シート参照式を消去する(シート)
    Next

End Sub

' 便利マクロはこちら
Sub アクティブシートの自シート参照式を消去する()
    Call 自シート参照式を消去する(ActiveSheet)
End Sub


' メインプロシージャ
Sub 自シート参照式を消去する(ws対象シート As Worksheet)
    
    ' Evaluate関数を正しく動かすためにActiveにしてから実行
    ws対象シート.Activate
    
    ' シート名!または'シート名'!を検索
    Dim 自シート参照式 As String: 自シート参照式 = ws対象シート.Name & "!"
    Dim 自シート参照式_SQ有 As String: 自シート参照式_SQ有 = "'" & ws対象シート.Name & "'!"
    
    ' 同一数式をもつ範囲ごとにUsedRangeを分割
    Dim Dic同一数式セル As Dictionary
    Set Dic同一数式セル = 同じ数式を持つセル範囲ごとに1つのItemとするDictionaryを取得する(ws対象シート)
    If Dic同一数式セル.Count = 0 Then Exit Sub
    
    ' 同一数式をもつ範囲ごとにループ
    Dim keyR1C1数式
    For Each keyR1C1数式 In Dic同一数式セル.Keys

        ' まずシングルクォートありを検索（これは発見した時点で置換）
        If InStr(keyR1C1数式, 自シート参照式_SQ有) > 0 Then
            Dic同一数式セル(keyR1C1数式).FormulaR1C1 = Replace(keyR1C1数式, 自シート参照式_SQ有, "")
                        
        ' シングルクォートなしを検索（これは発見してもシート名が後方一致しただけの可能性あり）
        ElseIf InStr(keyR1C1数式, 自シート参照式) > 0 Then
            
            Dim 第1セル As Range: Set 第1セル = Dic同一数式セル(keyR1C1数式).Cells(1)
            
            ' シート名!を'シート名'!に変えて数式をEvaluate関数で実行してみる。
            ' 本当に第2シートを参照していれば問題なく動いて同じ値を返す
            ' データ2025! というシートが2025!で引っかかってしまっているだけの場合は、
            ' データ'2025'!という参照式になってしまいエラーとなる
            ' この判定で串刺し計算式も置換対象外となる

            ' 元からエラーが出ている場合は、Evaluateの結果が同じエラーになったら置換
            If IsError(第1セル.Value) Then
                If 第1セル.Value = Evaluate(Replace(第1セル.Formula, 自シート参照式, 自シート参照式_SQ有)) Then
                    Dic同一数式セル(keyR1C1数式).FormulaR1C1 = Replace(keyR1C1数式, 自シート参照式, "")
                End If
            
            ' 元のセルがエラーでない場合は、Evaluateの結果がエラーになっていなければ置換
            Else
                If IsError(Evaluate(Replace(第1セル.Formula, 自シート参照式, 自シート参照式_SQ有))) = False Then
                    Dic同一数式セル(keyR1C1数式).FormulaR1C1 = Replace(keyR1C1数式, 自シート参照式, "")
                End If
                
            End If
        
        End If
    Next

End Sub

' 同一数式ごとにRangeを分けたDictionary
Function 同じ数式を持つセル範囲ごとに1つのItemとするDictionaryを取得する(ws対象シート As Worksheet) As Dictionary

    Dim Dic結果値 As New Dictionary
    
    ' 数式があるセルをループ
    Dim 数式セル As Range
    For Each 数式セル In ws対象シート.UsedRange
        If 数式セル.HasFormula Then
            
            ' KeyはR1C1数式
            Dim keyR1C1数式 As String: keyR1C1数式 = 数式セル.FormulaR1C1
            
            ' 新出の数式を登録
            If Dic結果値.Exists(keyR1C1数式) = False Then
                Dic結果値.Add keyR1C1数式, 数式セル
            
            ' 既出の数式であればItemに本セルをUnion
            Else
                Set Dic結果値(keyR1C1数式) = Union(Dic結果値(keyR1C1数式), 数式セル)
            
            End If
            
        End If
    
    Next
    
    Set 同じ数式を持つセル範囲ごとに1つのItemとするDictionaryを取得する = Dic結果値
    
End Function