列出工作簿中的所有公式及其位置和值

Public Sub ListFormulasInWorkbook()
 Const SHEETNAME As String = "公式位于*"
 Const ALLFORMULAS As Integer = xlNumbers + xlTextValues + xlLogical + xlErrors
 Const ROWLIM As Long = 65500
 Dim formulaSht As Worksheet
 Dim destRng As Range
 Dim cell As Range
 Dim wkSht As Worksheet
 Dim formulaRng As Range
 Dim shCnt As Long
 Dim oldScreenUpdating As Boolean
 
 With Application
   oldScreenUpdating = .ScreenUpdating
   .ScreenUpdating = False
 End With
 
 shCnt = 0
 ListFormulasAddSheet formulaSht, shCnt
 ' 列出每个工作表中的公式
 Set destRng = formulaSht.Range("A4")
 For Each wkSht In ActiveWorkbook.Worksheets
   If Not wkSht.Name Like SHEETNAME Then
     Application.StatusBar = wkSht.Name
     destRng.Value = wkSht.Name
     Set destRng = destRng.Offset(1, 0)
     On Error Resume Next
     Set formulaRng = wkSht.Cells.SpecialCells( _
       xlCellTypeFormulas, ALLFORMULAS)
     On Error GoTo 0
     If formulaRng Is Nothing Then
       destRng.Offset(0, 1).Value = "无"
       Set destRng = destRng.Offset(1, 0)
     Else
       For Each cell In formulaRng
         With destRng
           .Offset(0, 1) = cell.Address(0, 0)
           .Offset(0, 2) = "'" & cell.Formula
           .Offset(0, 3) = cell.Value
         End With
         Set destRng = destRng.Offset(1, 0)
         If destRng.Row > ROWLIM Then
           ListFormulasAddSheet formulaSht, shCnt
           Set destRng = formulaSht.Range("A5")
           destRng.Offset(-1, 0).Value = wkSht.Name
         End If
       Next cell
       Set formulaRng = Nothing
     End If
     With destRng.Resize(1, 4).Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = 5
     End With
     Set destRng = destRng.Offset(1, 0)
     If destRng.Row > ROWLIM Then
       ListFormulasAddSheet formulaSht, shCnt
       Set destRng = formulaSht.Range("A5")
       destRng.Offset(-1, 0).Value = wkSht.Name
     End If
   End If
 Next wkSht
 With Application
   .StatusBar = False
   .ScreenUpdating = oldScreenUpdating
 End With
End Sub

Private Sub ListFormulasAddSheet( _
   formulaSht As Worksheet, shtCnt As Long)
 Const SHEETNAME As String = "公式位于"
 Const SHEETTITLE As String = "公式位于 $ 汇总时间"
 Const DATEFORMAT As String = "dd MMM yyyy hh:mm"
 Dim shtName As String
 With ActiveWorkbook
   ' 删除已存在的工作表并创建一个新的工作表
   shtCnt = shtCnt + 1
   shtName = Left(SHEETNAME & .Name, 28)
   If shtCnt > 1 Then _
     shtName = shtName & "_" & shtCnt
   On Error Resume Next
   Application.DisplayAlerts = False
   .Worksheets(shtName).Delete
   Application.DisplayAlerts = True
   On Error GoTo 0
   Set formulaSht = .Worksheets.Add( _
     after:=Sheets(Sheets.Count))
 End With
 With formulaSht
   ' 公式标题
   .Name = shtName
   .Columns(1).ColumnWidth = 15
   .Columns(2).ColumnWidth = 8
   .Columns(3).ColumnWidth = 60
   .Columns(4).ColumnWidth = 40
   With .Range("C:D")
     .Font.Size = 9
     .HorizontalAlignment = xlLeft
     .EntireColumn.WrapText = True
   End With
   With .Range("A1")
     .Value = Application.Substitute(SHEETTITLE, "$", _
       ActiveWorkbook.Name) & Format(Now, DATEFORMAT)
     With .Font
       .Bold = True
       .ColorIndex = 5
       .Size = 14
     End With
   End With
   With .Range("A3").Resize(1, 4)
     .Value = Array("工作表", "地址", "公式", "值")
     With .Font
       .ColorIndex = 13
       .Bold = True
       .Size = 12
     End With
     .HorizontalAlignment = xlCenter
     With .Borders(xlEdgeBottom)
       .LineStyle = xlDouble
       .Weight = xlThick
       .ColorIndex = 5
     End With
   End With
 End With
End Sub