提取EXCEL工作表中公式的单元格的代码

最新推荐文章于 2024-03-08 22:24:18 发布

转载最新推荐文章于 2024-03-08 22:24:18 发布 · 3.1k 阅读

该脚本通过遍历指定工作表查找所有包含公式的单元格，并将这些单元格的相关信息（如地址、公式、值）提取到一个新工作表中，包括公式所在单元格、公式本身及对应数值。此过程同时更新工作表标题为源工作表名称加上“表中的公式”。脚本还包括了自动调整列宽和显示进度的功能。

Sub 提取带公式的单元格()
Dim FormulaCells As Range, Cell As Range
Dim FormulaSheet As Worksheet
Dim Row As Integer

'创建Range对象
On Error Resume Next
Set FormulaCells = Range("A1").SpecialCells(xlCellTypeFormulas, 23)

'没有找到公式
If FormulaCells Is Nothing Then
      MsgBox "当前工作表中没有公式！"
      Exit Sub
End If

'增加一个新工作表
Application.ScreenUpdating = False
Set FormulaSheet = ActiveWorkbook.Worksheets.Add
FormulaSheet.Name = "“" & FormulaCells.Parent.Name & "”表中的公式"

'列标题
With FormulaSheet
      Range("A1") = "公式所在单元格"
      Range("B1") = "公式"
      Range("C1") = "值"
      Range("A1:C1").Font.Bold = True
End With

'读取公式，同时在状态栏中显示进度。
Row = 2
For Each Cell In FormulaCells
      Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%")
      With FormulaSheet
         Cells(Row, 1) = Cell.Address _
            (RowAbsolute:=False, ColumnAbsolute:=False)
         Cells(Row, 2) = " " & Cell.Formula
         Cells(Row, 3) = Cell.Value
         Row = Row + 1
      End With
Next Cell

'调整列宽
FormulaSheet.Columns("A:C").AutoFit
Application.StatusBar = False

End Sub

---------------------------------------------------

Sub 提取带公式的单元格()
Dim FormulaCells As Range, Cell As Range
Dim FormulaSheet As Worksheet
Dim Row As Integer

'创建Range对象
On Error Resume Next
Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)

'没有找到公式
If FormulaCells Is Nothing Then
      MsgBox "当前工作表中没有公式！"
      Exit Sub
End If

'增加一个新工作表
Application.ScreenUpdating = False
Set FormulaSheet = ActiveWorkbook.Worksheets.Add
FormulaSheet.Name = "“" & FormulaCells.Parent.Name & "”表中的公式"

'列标题
With FormulaSheet
      Range("A1") = "公式所在单元格"
      Range("B1") = "公式"
      Range("C1") = "值"
      Range("A1:C1").Font.Bold = True
End With

'读取公式，同时在状态栏中显示进度。
Row = 2
For Each Cell In FormulaCells
      Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%")
      With FormulaSheet
         Cells(Row, 1) = Cell.Address _
            (RowAbsolute:=False, ColumnAbsolute:=False)
         Cells(Row, 2) = " " & Cell.Formula
         Cells(Row, 3) = Cell.Value
         Row = Row + 1
      End With
Next Cell

'调整列宽
FormulaSheet.Columns("A:C").AutoFit
Application.StatusBar = False
End Sub