『記入関数を一覧表のように表示する』（マサイ）

シート内に記入した全ての関数式を別シートに
どこのセルで
どんな関数式が使われたか
一覧表示する方法（VBA)はありますか？

例えば、sheet1が下記の場合

    |[A]        |[B]     |[C]
 [2]|     123456|=LEN(A2)|   
 [3]|        789|=LEN(A3)|   
 [4]|       2562|=LEN(A4)|   
 [5]|=SUM(A2:A4)|        |   
 
 
sheet2に以下のように書き出す
 
     |[A]|[B]       
 [1]|B2  |=LEN(A2)   
 [2]|B3  |=LEN(A3)   
 [3]|B4  |=LEN(A4)   
 [4]|A5  |=SUM(A2:A4)

書き出す型式は、他に分かりやす型式があれば
上記にはこだわりはありません。



＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
----
 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Dim rng As Range, i As Long
     Set ws1 = Worksheets("Sheet1")
     Set ws2 = Worksheets("Sheet2")
     For Each rng In ws1.Range("A1").CurrentRegion
         If rng.HasFormula Then
             i = i + 1
             ws2.Cells(i, "A") = rng.Address(0, 0)
             ws2.Cells(i, "B") = "'" & rng.Formula
         End If
     Next
 End Sub
（フォーキー） 2023/03/01(水) 19:00:41
----
フォーキーさん、コードありがとうございます。

CurrentRegionでA1の塊を候補にしていますが
他にも塊でない場所にも関数を書いたセルがあります。

アクティブシート内の使用中の全てのセルを対象にしたいので
以下を考えましたがエラーは出ませんが上手くいきません。

どう変更すれば良いですか？

 Sub 関数一覧()
     Dim ws2 As Worksheet
     Dim i As Long
     
     Set ws2 = Worksheets("Sheet2")
     
     With ActiveSheet.UsedRange
         If .HasFormula Then
             i = i + 1
             ws2.Cells(i, "A") = rng.Address(0, 0)
             ws2.Cells(i, "B") = "'" & rng.Formula
         End If
     End With
 End Sub


（マサイ） 2023/03/02(木) 08:10:26

----
思いつきで試したら上手く処理されました。


Option Explicit

Sub 関数一覧()
    Dim ws2 As Worksheet, Asht As Worksheet
    Dim rng As Range, i As Long
     
    Set ws2 = Worksheets("Sheet2")
    Set Asht = ActiveSheet
     
    For Each rng In Asht.UsedRange
        If rng.HasFormula Then
            i = i + 1
            ws2.Cells(i, "A") = rng.Address(0, 0)
            ws2.Cells(i, "B") = "'" & rng.Formula
        End If
    Next
End Sub


できたらB列のセルがどんな数式なのかを説明したセルが周囲にあるのですが
これをC列に書き込みたいと思いますが何か方法がありますか？


例えば

k12 : 時間4

      |[A]|[L]         |[C] 
 [12] |K7 |=HOUR(J5)  |時間4

 
 問題なのは、説明したセルが数式の周囲にあるので
 以下の場合では、８つの内どれを指定するかを手動で選択すると言うことです。
 （上の場合は、左側の「時間４」を選択）
 
     |[K]   |[L]      |[M]   
 [11]|時間１|時間２   |時間３
 [12]|時間４|=HOUR(J5)|時間５
 [13]|時間６|時間７   |時間８
 
 
（マサイ） 2023/03/02(木) 08:39:03
----
γさん、アドバイス感謝します。

CtrlとShiftキーを押しながら@キーで式モードになる。
なるほど便利な機能ですね。

式モードは、それはそれで便利なのですが
やはり一覧表は、捨てがたいです。

08:10:26で提案した一覧表（説明付き）を完成させたいと思います。
何か、方法があればお願いします。
（マサイ） 2023/03/02(木) 08:48:44
----
Sub 関数一覧()
    Dim Asht As Worksheet, Resultws As Worksheet
    Dim rng As Range, i As Long
    Dim TargetCells As Long
    Set Asht = ActiveSheet
    Set Resultws = ThisWorkbook.Worksheets("Sheet2")
    
    On Error GoTo ErrHandl
    TargetCells = Asht.Cells.SpecialCells(xlCellTypeFormulas, 23).Count
    On Error GoTo 0
    
    Resultws.Range("A1").CurrentRegion.Clear
    
    Application.DisplayAlerts = False
    
    On Error GoTo nextloop
    ReDim PasteArr(1 To TargetCells, 1 To 3)
    For Each rng In Asht.Cells.SpecialCells(xlCellTypeFormulas, 23)
        i = i + 1
        PasteArr(i, 1) = rng.Address(0, 0)
        PasteArr(i, 2) = "'" & rng.Formula
        Asht.Activate
        rng.Select
        PasteArr(i, 3) = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください", Type:=8).Value
nextloop:
    Err.Clear
    Next
    On Error GoTo 0
    
    Application.DisplayAlerts = True
    
    Resultws.Range("A1", Resultws.Cells(TargetCells, 3)) = PasteArr
    Exit Sub
    
ErrHandl:
    MsgBox ("数式は見つかりませんでした。")
    Err.Clear
End Sub
（cZnc2hu00T） 2023/03/02(木) 10:58:12
----
cZnc2hu00Tさん、参加いただきありがとうございます。

早速コードを試してみました。
思い描いていた手順で説明が設定できるので何点かは除いて完璧です。

試用したシートに結合セルがあるので何箇所か
B列が空欄のセルができました。
これは、後でB列が空欄のセルは、行を削除すれば問題ないと思います。

構想が甘く月ごとの集計のようなシート構成では、
同じ列に縦長に日付が日数分ある場合、計算式も同じ数だけ配置される場合は何度も同じ説明を選択する事です。
そこでVBAで行が更新されて同じ列が出た場合に、
例えば「F列は、2度めですが同じ説明ですか？」と聞くようにして
「Y」でF列の説明を最初の説明と同じとして以後問い合わせをしないようにコードを変更したいのですができますか　？


（マサイ） 2023/03/02(木) 12:29:20
----
Sub 関数一覧()
    Dim Overlapcheck As Object
    Dim OverlapOK As Object
    Set Overlapcheck = CreateObject("Scripting.Dictionary")
    Set OverlapOK = CreateObject("Scripting.Dictionary")
    
    Dim Asht As Worksheet, Resultws As Worksheet
    Dim rng As Range, i As Long
    Dim TargetCells As Long
    Set Asht = ActiveSheet
    Set Resultws = ThisWorkbook.Worksheets("Result")
    
    On Error GoTo ErrHandl
    TargetCells = Asht.Cells.SpecialCells(xlCellTypeFormulas, 23).Count
    On Error GoTo 0
    
    Resultws.Range("A1").CurrentRegion.Clear
    
    Application.DisplayAlerts = False
    
    ReDim PasteArr(1 To TargetCells, 1 To 3)
    For Each rng In Asht.Cells.SpecialCells(xlCellTypeFormulas, 23)
        If (rng.Formula <> "") Then
            i = i + 1
            PasteArr(i, 1) = rng.Address(0, 0)
            PasteArr(i, 2) = "'" & rng.Formula
            PasteArr(i, 3) = Explain(Overlapcheck, OverlapOK, Asht, rng)
        End If
    Next
    On Error GoTo 0
    
    Application.DisplayAlerts = True
    
    Resultws.Range("A1", Resultws.Cells(TargetCells, 3)) = PasteArr
    Exit Sub
    
ErrHandl:
    MsgBox ("数式は見つかりませんでした。")
    Err.Clear
End Sub

Function Explain(ByRef Overlapcheck As Object, ByRef OverlapOK As Object, ByRef Asht As Worksheet, ByRef rng As Range) As String
    Dim CheckColumn
    CheckColumn = Split(rng.Address, "$")(1)
    
    On Error GoTo nextloop
    If Overlapcheck.exists(CheckColumn) Then
        If (OverlapOK.exists(CheckColumn)) Then
            Explain = Overlapcheck.Item(CheckColumn)
        Else
            If (MsgBox(CheckColumn & "列は前に" & Overlapcheck.Item(CheckColumn) & _
                "と入力されていますが、以降同じ説明ですか?", vbYesNo) = vbYes) Then
                OverlapOK.Add Item:=True, Key:=CheckColumn
                Explain = Overlapcheck.Item(CheckColumn)
            Else
                Asht.Activate
                rng.Select
                Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください", Type:=8).Value
                Overlapcheck.Remove CheckColumn
                Overlapcheck.Add Item:=Explain, Key:=CheckColumn
            End If
        End If
    Else
        Asht.Activate
        rng.Select
        Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください", Type:=8).Value
        Overlapcheck.Add Item:=Explain, Key:=CheckColumn
    End If
    On Error GoTo 0
    
    Exit Function
    
nextloop:
    Err.Clear
End Function

（cZnc2hu00T） 2023/03/02(木) 14:06:58
----
同じ説明を加味した修正コードありがとうございます。
結合セルの処理も追加いただきバッチリ結果がでるようになりました。


大満足で結果を書き出すシートを「関数一覧」として
「関数一覧」シートの有無でシートを作成するか/しないかを判断するコードを追加しましたが
どうもActiveSheetを設定するコードに不備があるようで上手く書き出されません。

又、途中で以下のコードで「インデックスが有効範囲にありません。」のエラーがでました。
PasteArr(i, 1) = rng.Address(0, 0)

すいませんが、コードを見ていただけませんか？


Option Explicit

Sub 関数一覧3()

    Dim Overlapcheck As Object
    Dim OverlapOK As Object
    Set Overlapcheck = CreateObject("Scripting.Dictionary")
    Set OverlapOK = CreateObject("Scripting.Dictionary")
    Dim Asht As Worksheet, Resultws As Worksheet, temp As Worksheet
    Dim rng As Range, i As Long
    Dim TargetCells As Long
    Dim flg As Long
    
    
    Set Asht = ActiveSheet
    
    '関数一覧シートの存在チェック
    For i = 1 To Sheets.Count
        If Sheets(i).Name = "関数一覧" Then
            flg = 1
        End If
    Next
    
    If flg <> 1 Then
        Set temp = Sheets.Add(after:=Sheets(Sheets.Count))
        temp.Name = "関数一覧"
    End If
    
    Asht.Activate
    Set Resultws = Worksheets("関数一覧")
    
    On Error GoTo ErrHandl
    'データの種別が数式、文字、論理値、エラー値であるセルをカウント
    TargetCells = Asht.Cells.SpecialCells(xlCellTypeFormulas, 23).Count
    
    On Error GoTo 0
    '書き出しシート初期化（クリアー）
    Resultws.Range("A1").CurrentRegion.Clear
    
    Application.DisplayAlerts = False
    
    ReDim PasteArr(1 To TargetCells, 1 To 3)
    
    For Each rng In Asht.Cells.SpecialCells(xlCellTypeFormulas, 23)
        If (rng.Formula <> "") Then
            i = i + 1
            PasteArr(i, 1) = rng.Address(0, 0)
            PasteArr(i, 2) = "'" & rng.Formula
            
            '独自関数(説明記入)
            PasteArr(i, 3) = Explain(Overlapcheck, OverlapOK, Asht, rng)
        End If
    Next
    
    On Error GoTo 0  'エラー処理を無効にする
    Application.DisplayAlerts = True
    Resultws.Range("A1", Resultws.Cells(TargetCells, 3)) = PasteArr
    Exit Sub
    
ErrHandl:
    MsgBox ("数式は見つかりませんでした。")
    Err.Clear
End Sub
Function Explain(ByRef Overlapcheck As Object, ByRef OverlapOK As Object, ByRef Asht As Worksheet, ByRef rng As Range) As String
    Dim CheckColumn
    
    CheckColumn = Split(rng.Address, "$")(1)
    
    On Error GoTo nextloop
    If Overlapcheck.exists(CheckColumn) Then
        If (OverlapOK.exists(CheckColumn)) Then
            Explain = Overlapcheck.Item(CheckColumn)
        Else
            If (MsgBox(CheckColumn & "列は前に" & Overlapcheck.Item(CheckColumn) & _
                "と入力されていますが、以降同じ説明で良いですか ?", vbYesNo) = vbYes) Then
                OverlapOK.Add Item:=True, Key:=CheckColumn
                Explain = Overlapcheck.Item(CheckColumn)
            Else
                Asht.Activate
                rng.Select
                Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください。", Type:=8).Value
                Overlapcheck.Remove CheckColumn
                Overlapcheck.Add Item:=Explain, Key:=CheckColumn
            End If
        End If
    Else
        Asht.Activate
        rng.Select
        Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください。", Type:=8).Value
        Overlapcheck.Add Item:=Explain, Key:=CheckColumn
    End If
    
    On Error GoTo 0
    Exit Function
nextloop:
    Err.Clear
    
End Function


（マサイ） 2023/03/02(木) 17:21:15
----
変更点
変数tempの役割がResultwsと被っていたため統合(最後にResultwsに書き出しているのでどのみち正常に動かないです)
変数flgの名前をわかりやすく変更
変数iが二ヶ所で使われてしまっていたため片方の名前を変更(これが"インデックスが有効範囲にありません。"というエラーが出た原因)

Sub 関数一覧3()
    Dim Overlapcheck As Object
    Dim OverlapOK As Object
    Set Overlapcheck = CreateObject("Scripting.Dictionary")
    Set OverlapOK = CreateObject("Scripting.Dictionary")
    Dim Asht As Worksheet, Resultws As Worksheet
    Dim rng As Range, i As Long, inArr As Long
    Dim ResultwsCheck As Boolean
    Dim TargetCells As Long
    Set Asht = ActiveSheet
    '関数一覧シートの存在チェック
    ResultwsCheck = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name = "関数一覧" Then
            ResultwsCheck = True
            Set Resultws = Worksheets("関数一覧")
        End If
    Next
    If Not ResultwsCheck Then
        Set Resultws = Sheets.Add(after:=Sheets(Sheets.Count))
        Resultws.Name = "関数一覧"
    End If
    Asht.Activate
    On Error GoTo ErrHandl
    'データの種別が数式、文字、論理値、エラー値であるセルをカウント
    TargetCells = Asht.Cells.SpecialCells(xlCellTypeFormulas, 23).Count
    On Error GoTo 0
    '書き出しシート初期化（クリアー）
    Resultws.Range("A1").CurrentRegion.Clear
    Application.DisplayAlerts = False
    ReDim PasteArr(1 To TargetCells, 1 To 3)
    For Each rng In Asht.Cells.SpecialCells(xlCellTypeFormulas, 23)
        If (rng.Formula <> "") Then
            inArr = inArr + 1
            PasteArr(inArr, 1) = rng.Address(0, 0)
            PasteArr(inArr, 2) = "'" & rng.Formula
            '独自関数(説明記入)
            PasteArr(inArr, 3) = Explain(Overlapcheck, OverlapOK, Asht, rng)
        End If
    Next
    On Error GoTo 0  'エラー処理を無効にする
    Application.DisplayAlerts = True
    Resultws.Range("A1", Resultws.Cells(TargetCells, 3)) = PasteArr
    Exit Sub
ErrHandl:
    MsgBox ("数式は見つかりませんでした。")
    Err.Clear
End Sub
Function Explain(ByRef Overlapcheck As Object, ByRef OverlapOK As Object, ByRef Asht As Worksheet, ByRef rng As Range) As String
    Dim CheckColumn
    CheckColumn = Split(rng.Address, "$")(1)
    On Error GoTo nextloop
    If Overlapcheck.exists(CheckColumn) Then
        If (OverlapOK.exists(CheckColumn)) Then
            Explain = Overlapcheck.Item(CheckColumn)
        Else
            If (MsgBox(CheckColumn & "列は前に" & Overlapcheck.Item(CheckColumn) & _
                "と入力されていますが、以降同じ説明で良いですか ?", vbYesNo) = vbYes) Then
                OverlapOK.Add Item:=True, Key:=CheckColumn
                Explain = Overlapcheck.Item(CheckColumn)
            Else
                Asht.Activate
                rng.Select
                Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください。", Type:=8).Value
                Overlapcheck.Remove CheckColumn
                Overlapcheck.Add Item:=Explain, Key:=CheckColumn
            End If
        End If
    Else
        Asht.Activate
        rng.Select
        Explain = Application.InputBox(prompt:=rng.Address(0, 0) & "の説明を選択してください。", Type:=8).Value
        Overlapcheck.Add Item:=Explain, Key:=CheckColumn
    End If
    On Error GoTo 0
    Exit Function
nextloop:
    Err.Clear
End Function
（cZnc2hu00T） 2023/03/03(金) 08:24:06
----
cZnc2hu00Tさん、昨日に続きコードの修正ありがとうございます。

エラー「インデックスが有効範囲にありません。」についてですが

シートの構成を少しずつ替えて数パターンでマクロを試してみた結果
エラーが出るのは、同じ列で既に説明を記入したセルがあって更に
同列で途中に何も記入されていない空白のセルがあるに場合に発生していました。

昨日から変数(i)の使い回しが原因とは、思いもよらず
全く違うところに着目して泥沼に入り込んで悪戦苦闘していました。

まだ、数パターンしか試していませんが教えてもらったコードで上手く処理されています。

アドバイス感謝いたします。

（マサイ） 2023/03/03(金) 10:18:04
----
最後に下記処理を追加してこれで一応完成と思います。

関数一覧.Range("A1").CurrentRegion.Sort key1:=関数一覧.Range("A1"), Order1:=xlAscending
（マサイ） 2023/03/03(金) 10:49:13