如何在不重复多次每个数组公式的情况下遍历工作表中的所有公式和数组公式？

Question

我想编写一个VBA函数，输出工作表中所有单个公式和数组公式的列表。我希望一个范围的数组公式只打印一次。

如果我按照以下方式遍历所有UsedRange.Cells，它将多次打印每个数组公式，因为它涵盖了多个单元格，这不是我想要的。

 For Each Cell In CurrentSheet.UsedRange.Cells
     If Cell.HasArray Then
        St = Range(" & Cell.CurrentArray.Address & ").FormulaArray = " _
                & Chr(34) & Cell.Formula & Chr(34)
     ElseIf Cell.HasFormula Then
        St = Range(" & Cell.Address & ").FormulaR1C1 = " _
                & Chr(34) & Cell.Formula & Chr(34)
     End If
     Print #1, St
 Next

有没有好的方法可以避免这个问题？

- SoftTimur

---

如果您查看我的个人资料，您将会看到我的 Mappit 加载项。该加载项会生成每张工作表的所有唯一公式列表 - 以及一个标识唯一公式的地图。 - brettdj

Answer 1

以下代码会生成如下输出：

$B$7 -> =SUM(B3:B6)
$B$10 -> =AVERAGE(B3:B6)
$D$10:$D$13 -> =D5:D8
$F$14:$I$14 -> =TRANSPOSE(D5:D8)

我正在使用一个集合，但同样也可以使用字符串。

Sub GetFormulas()
    Dim ws As Worksheet
    Dim coll As New Collection
    Dim rngFormulas As Range
    Dim rng As Range
    Dim iter As Variant

    Set ws = ActiveSheet
    On Error Resume Next
    Set rngFormulas = ws.Range("A1").SpecialCells(xlCellTypeFormulas)
    If rngFormulas Is Nothing Then Exit Sub 'no formulas
    For Each rng In rngFormulas
        If rng.HasArray Then
            If rng.CurrentArray.Range("A1").Address = rng.Address Then
                coll.Add rng.CurrentArray.Address & " -> " & _
                    rng.Formula, rng.CurrentArray.Address
            End If
        Else
            coll.Add rng.Address & " -> " & _
                rng.Formula, rng.Address
        End If
    Next rng
    For Each iter In coll
        Debug.Print iter
        'or Print #1, iter
    Next iter
    On Error GoTo 0     'turn on error handling
End Sub

主要区别在于，只有当当前正在检查的单元格是CurrentArray中的单元格A1时，我才将数组公式写入集合中；也就是说，只有当它是数组范围的第一个单元格时。

另一个区别在于，我仅使用SpecialCells查看包含公式的单元格，这比检查UsedRange更加高效。

- Andy G

---

我最初使用了一个集合，因为我希望如果项目已经在集合中存在，则不添加它们，但这证明有点棘手。另一种选择是使用字典。 - Andy G

一个奇怪的事情是，当工作表中没有公式时，ws.Cells.SpecialCells(xlCellTypeFormulas) 会引发错误... - SoftTimur

@SoftTimur 是的，当SpecialCells失败时，“On Error Resume Next”无效。我正在研究绕过这个问题的方法。 - Andy G

实际上，On Error Resume Next 是有效的，只是我设置了“在所有错误上中断”。我已经将错误检查添加到我的答案中。 - Andy G

你的第二个版本太“高效”了。它假设公式是唯一的Range区域，但这通常不是这种情况。例如，在相邻单元格中放置两个不同的公式，如下所示：A1: =42和A2: =99。输出将是“$A$1:$A$2 -> =42”。我认为除了像你在第一个版本中那样迭代每个具有公式的单元格之外，没有其他选择。 - jtolle

感谢@jtolle，发现得好。我已经删除了第二个版本，因为使用“Areas”没有意义，如果我们之后还要查看这些区域。 - Andy G

Answer 2

你需要跟踪你已经看过的内容。简单的方法是使用Excel提供的Union和Intersect方法，以及Range的CurrentArray属性。

我刚刚输入了这个，所以我不保证它是全面的或没有错误的，但它演示了基本思想：

Public Sub debugPrintFormulas()
    Dim checked As Range

    Dim c As Range
    For Each c In Application.ActiveSheet.UsedRange
        If Not alreadyChecked_(checked, c) Then
            If c.HasArray Then
                Debug.Print c.CurrentArray.Address, c.FormulaArray

                Set checked = accumCheckedCells_(checked, c.CurrentArray)
            ElseIf c.HasFormula Then
                Debug.Print c.Address, c.Formula

                Set checked = accumCheckedCells_(checked, c)
            End If
        End If
    Next c
End Sub

Private Function alreadyChecked_(checked As Range, toCheck As Range) As Boolean
    If checked Is Nothing Then
        alreadyChecked_ = False
    Else
        alreadyChecked_ = Not (Application.Intersect(checked, toCheck) Is Nothing)
    End If
End Function

Private Function accumCheckedCells_(checked As Range, toCheck As Range) As Range
    If checked Is Nothing Then
        Set accumCheckedCells_ = toCheck
    Else
        Set accumCheckedCells_ = Application.Union(checked, toCheck)
    End If
End Function

- jtolle

---

我本来想写一条关于字典更高效的评论...但是我收回了。非常聪明。 - Pynner

@Pynner，谢谢。对于我的用例，性能并不重要。我只在将公式写入文本文件以进行版本控制时才会做这种事情，因此假设任何合理的算法，处理工作表不会成为瓶颈。但是，虽然我不确定，但我认为“Range”在幕后实际上相当高效。（我想您可以通过仅累积数组公式范围来优化我的示例。正如@Andy G所指出的那样，只查看具有公式的单元格。） - jtolle

Answer 3

我认为你的问题唯一可靠的解决方案是交叉检查每个新公式以确保没有重复。根据信息量和速度要求的不同，您应该依赖于不同的方法。

如果大小不太重要（预期记录数在1000以下），则应该依赖于数组，因为这是最快的选项，并且其实现非常简单。例如：

Dim stored(1000) As String
Dim storedCount As Integer

Sub Inspect()

 Open "temp.txt" For Output As 1
 For Each Cell In CurrentSheet.UsedRange.Cells
     If Cell.HasArray Then
        St = Range(" & Cell.CurrentArray.Address & ").FormulaArray = " _
                & Chr(34) & Cell.Formula & Chr(34)
     ElseIf Cell.HasFormula Then
        St = Range(" & Cell.Address & ").FormulaR1C1 = " _
                & Chr(34) & Cell.Formula & Chr(34)
     End If
     If(Not alreadyAccounted(St) And storedCount <= 1000) Then
        storedCount = storedCount + 1
        stored(storedCount) = St
        Print #1, St
     End If
 Next
 Close 1
End Sub

Function alreadyAccounted(curString As String) As Boolean
    Dim count As Integer: count = 0

    Do While (count < storedCount)
        count = count + 1
        If (LCase(curString) = LCase(stored(count))) Then
            alreadyAccounted = True
            Exit Function
        End If
    Loop
End Function

如果预期的记录数量非常大，我会依赖文件存储/检查。依赖Excel（将检查的单元格与新范围相关联并在其中查找匹配项）会更容易，但速度较慢（特别是在有大量单元格的情况下）。因此，一种可靠且足够快速的方法（虽然比前述数组慢得多）是从alreadyAccounted读取您正在创建的文件（我想是一个.txt文件）。

- varocarbas