请求修改Excel VBA宏：列出所有工作表及公式（含无公式工作表）

我调试了一个VBA宏，它能在工作簿新建工作表，把带公式的工作表名称、单元格地址、对应公式分别列在A、B、C列，运行正常。现在需要修改宏，让无公式的工作表名称也显示在列表中，对应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

修改后的宏代码 #

Sub ListAllFormulas()
Dim sht As Worksheet
    Dim shtName
    Dim myRng As Range
    Dim newRng As Range
    Dim c As Range
    Dim outputRow As Long ' 记录输出行位置，提升效率
    
ReTry:
    shtName = Application.InputBox("Choose a name for the new sheet to list all formulas.", "New Sheet Name")
    If shtName = False Then Exit Sub
     
    On Error Resume Next
    Set sht = Sheets(shtName)
    If Not sht Is Nothing Then
        MsgBox "This sheet already exists"
        Err.Clear
        Set sht = Nothing
        GoTo ReTry
    End If
     
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A1").Value = "Sheet Name"
        .Range("B1").Value = "Cell Address"
        .Range("C1").Value = "Formula"
        .Name = shtName
    End With
     
    ' 初始化输出行，从标题行下一行开始
    outputRow = 2
     
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name <> shtName Then
            Set myRng = sht.UsedRange
            Dim hasFormulas As Boolean
            hasFormulas = False
            
            ' 查找工作表中的公式单元格
            On Error Resume Next
            Set newRng = myRng.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0 ' 恢复默认错误处理
            
            ' 如果有公式，遍历输出
            If Not newRng Is Nothing Then
                hasFormulas = True
                For Each c In newRng
                    Sheets(shtName).Cells(outputRow, "A").Value = sht.Name
                    Sheets(shtName).Cells(outputRow, "B").Value = Replace(c.Address, "$", "")
                    Sheets(shtName).Cells(outputRow, "C").Value = Mid(c.Formula, 2)
                    outputRow = outputRow + 1
                Next c
                Set newRng = Nothing ' 清空对象变量
            End If
            
            ' 如果无公式，仅输出工作表名称
            If Not hasFormulas Then
                Sheets(shtName).Cells(outputRow, "A").Value = sht.Name
                outputRow = outputRow + 1
            End If
        End If
    Next sht
    Sheets(shtName).Activate
    ActiveSheet.Columns("A:C").AutoFit
    Application.ScreenUpdating = True
    
End Sub

关键修改说明 #

• 移除原代码中跳过无公式工作表的GoTo逻辑，改为主动判断工作表是否包含公式
• 新增outputRow变量记录输出位置，替代原代码中重复查找最后一行的低效操作
• 调整错误处理逻辑，避免后续代码受On Error Resume Next的影响
• 新增无公式工作表的输出分支：仅填写A列工作表名称，B、C列留空

内容的提问来源于stack exchange，提问作者Marwan Barakat