标签：VBA
下面的程序将在一个新工作表中列出当前工作簿中所有工作表中的公式，以及这些公式所有的工作表、单元格及值。
代码如下：
代码语言：javascript复制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示例工作簿运行代码后的结果如下图1所示。
图1
欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
