创建包含工作表及其中的公式的列表

Question

我已经调试并开发了一个嵌入在下面宏的注释中的源宏。 该宏创建工作簿中所有公式的列表。将添加一个新工作表，并且公式（包括工作表名称和单元格地址）列在 A、B 和 C 列中。 现在宏可以正常工作了。 我需要开发宏的帮助，以便不包含公式的工作表的名称也出现在列表中，将单元格地址和相应的公式留空。 这是一个解释 该工作簿包含 4 个工作表，名称为：1 到 4。第一个工作表（名为 1）不包含公式。其余工作表（名为 2、3、4）包含公式。 以当前形式执行宏的结果如下：

Sheet Name  Cell Address    Formula
2   A1  2+1
3   A3  SUM(A1:A2)
3   B3  A3+1
4   F4  D4-C9
4   B9  SUM(B7:B8)
4   C9  SUM(C7:C8)

我想要得到的结果是：

Sheet Name  Cell Address    Formula
1       
2   A1  2+1
3   A3  SUM(A1:A2)
3   B3  A3+1
4   F4  D4-C9
4   B9  SUM(B7:B8)
4   C9  SUM(C7:C8)

这是当前形式的宏代码：

Sub ListAllFormulas()
'Original Source: http://www.vbaexpress.com/kb/getarticle.php?kb_id=409
Dim sht As Worksheet
    Dim shtName
    Dim myRng As Range
    Dim newRng As Range
    Dim c As Range
     
ReTry:
    shtName = Application.InputBox("Choose a name for the new sheet to list all formulas.", "New Sheet Name") 'the user decides the new sheet name
    If shtName = False Then Exit Sub 'exit if user clicks Cancel
     
    On Error Resume Next
    Set sht = Sheets(shtName) 'check if the sheet exists
    If Not sht Is Nothing Then 'if so, send message and return to input box
        MsgBox "This sheet already exists"
        Err.Clear 'clear error
        Set sht = Nothing 'reset sht for next test
        GoTo ReTry 'loop to input box
    End If
     
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count) 'adds a new sheet at the end
    Application.ScreenUpdating = False
    With ActiveSheet 'the new sheet is automatically the activesheet
        .Range("A1").Value = "Sheet Name" 'puts a heading in cell A1
        .Range("B1").Value = "Cell Address" 'puts a heading in cell B1
        .Range("C1").Value = "Formula" 'puts a heading in cell C1
        .Name = shtName 'names the new sheet from InputBox
    End With
     
    For Each sht In ActiveWorkbook.Worksheets 'loop through the sheets in the workbook
        If sht.Name <> shtName Then 'exclude the sheet just created
            Set myRng = sht.UsedRange 'limit the search to the UsedRange
            If Not myRng.HasFormula Then GoTo 50 'Skip the worksheet if it does not contain formulas.
            On Error Resume Next 'in case there are no formulas
            Set newRng = myRng.SpecialCells(xlCellTypeFormulas) 'use SpecialCells to reduce looping further
            For Each c In newRng 'loop through the SpecialCells only
                
                Sheets(shtName).Range("A65536").End(xlUp).Offset(1, 0).Value = sht.Name
                 'places the sheet name containing the formula in column A
                Sheets(shtName).Range("B65536").End(xlUp).Offset(1, 0).Value = Application.WorksheetFunction.Substitute(c.Address, "$", "")
                 'places the cell address, minus the "$" signs, containing the formula in column B
                 Sheets(shtName).Range("C65536").End(xlUp).Offset(1, 0).Value = Mid(c.Formula, 2, (Len(c.Formula)))
                 'places the formula minus the '=' sign in column C
50:
    Next c
        End If
    Next sht
    Sheets(shtName).Activate 'make the new sheet the activesheet
    ActiveSheet.Columns("A:C").AutoFit 'autofit the data
    Application.ScreenUpdating = True
    
End Sub

当前宏仅显示包含公式的工作表列表。我想要的是显示所有工作表的开发。

Answer 1

我添加了一个名为 boolSheetHasFormula 的新变量布尔类型。

在循环访问代码中的工作表之前，此变量最初将设置为 false。

如果有公式，变量 boolSheetHasFormula 在 For 循环中设置为 true - “仅循环特殊单元格”。

当您的代码跳转到标签 50 时：我添加了一个新代码来检查变量是否为 False，如果是，则代码会将工作表名称和连字符添加到其他两列“单元格地址”和“公式”中。 在这两列上添加了连字符，以便 xlUp 正确定位。如果您愿意，您可以将它们变成一个空间。

在 If 条件之后，我将变量更改回 False，因此该过程对于其他工作表的工作方式相同。

床单图片 名为 1 的工作表：无公式的工作表

名为 2 的工作表：带有公式

子列表所有公式() '原始来源：http://www.vbaexpress.com/kb/getarticle.php?kb_id=409 作为工作表变暗 昏暗的名字 调暗我的范围 暗淡 newRng 作为范围 调暗范围 Dim boolSheetHasFormula As Boolean ' 于 2024 年 5 月 11 日新增

重试： shtName = Application.InputBox("为新工作表选择一个名称以列出所有公式。", "新工作表名称") '用户决定新工作表名称 If shtName = False then Exit Sub '如果用户单击取消则退出

On Error Resume Next
Set sht = Sheets(shtName) 'check if the sheet exists
If Not sht Is Nothing Then 'if so, send message and return to input box
    MsgBox "This sheet already exists"
    Err.Clear 'clear error
    Set sht = Nothing 'reset sht for next test
    GoTo ReTry 'loop to input box
End If
 
Worksheets.Add.Move after:=Worksheets(Worksheets.Count) 'adds a new sheet at the end
Application.ScreenUpdating = False
With ActiveSheet 'the new sheet is automatically the activesheet
    .Range("A1").Value = "Sheet Name" 'puts a heading in cell A1
    .Range("B1").Value = "Cell Address" 'puts a heading in cell B1
    .Range("C1").Value = "Formula" 'puts a heading in cell C1
    .Name = shtName 'names the new sheet from InputBox
End With

boolSheetHasFormula = False

For Each sht In ActiveWorkbook.Worksheets 'loop through the sheets in the workbook
    If sht.Name <> shtName Then 'exclude the sheet just created
        Set myRng = sht.UsedRange 'limit the search to the UsedRange
        If Not myRng.HasFormula Then GoTo 50 'Skip the worksheet if it does not contain formulas.
        On Error Resume Next 'in case there are no formulas
        Set newRng = myRng.SpecialCells(xlCellTypeFormulas) 'use SpecialCells to reduce looping further
        For Each c In newRng 'loop through the SpecialCells only
            boolSheetHasFormula = True ' Added Newly on 11 May 2024
                
            Sheets(shtName).Range("A65536").End(xlUp).Offset(1, 0).Value = sht.Name
             'places the sheet name containing the formula in column A
            Sheets(shtName).Range("B65536").End(xlUp).Offset(1, 0).Value = Application.WorksheetFunction.Substitute(c.Address, "$", "")
             'places the cell address, minus the "$" signs, containing the formula in column B
             Sheets(shtName).Range("C65536").End(xlUp).Offset(1, 0).Value = Mid(c.Formula, 2, (Len(c.Formula)))
             'places the formula minus the '=' sign in column C

50： ' 新代码 ' 新代码包括所有工作表，无论公式是否存在。 此外，现在还考虑了没有公式的工作表。 ' 我已经放入了一个 hihen，以便 xlUp 定位正确。 如果不是 boolSheetHasFormula 那么 工作表(shtName).范围("A65536").End(xlUp).Offset(1, 0).Value = sht.Name 工作表(shtName).Range("B65536").End(xlUp).Offset(1, 0).Value = "" 工作表(shtName).Range("C65536").End(xlUp).Offset(1, 0).Value = "" 万一 boolSheetHasFormula = False ' 新代码结束 下一个c 万一 下一个嘘 Sheets(shtName).Activate '使新工作表成为活动工作表 ActiveSheet.Columns("A:C").AutoFit '自动调整数据 应用程序.ScreenUpdating = True

结束子

输出表