Loop Though All UDF Names in Project

问题

This question: Searching for function usage in Excel VBA got me thinking about a process for automating a search for all UDFs being used in a spreadsheet. Something along the lines of:

For Each UDF in Module1
    If Cells.Find(What:=UDF.Name, After:="A1", LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False) Then
        MsgBox UDF.Name & " is in use"
    End If
Next UDF

Is this possible and if so, what would the syntax be for looping through all UDFs?

回答1:

Option Explicit

' Add reference to Microsoft Visual Basic for Applications Extensibility 5.3 Library

Public Sub FindFunctionUsage()
    Dim udfs
    udfs = ListProcedures("Module1")
    If Not IsArray(udfs) Then _
        Exit Sub

    Dim udf
    Dim findResult

    For Each udf In udfs
        Set findResult = Cells.Find(What:="=" & udf, After:=Cells(1), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False)

        If Not findResult Is Nothing Then _
            MsgBox udf & " is in use"
    Next udf
End Sub

' Source for ListProcedures : http://www.cpearson.com/excel/vbe.aspx
Private Function ListProcedures(moduleName As String)
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Dim NumLines As Long
        Dim WS As Worksheet
        Dim rng As Range
        Dim ProcName As String
        Dim ProcKind As VBIDE.vbext_ProcKind

        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents(moduleName)
        Set CodeMod = VBComp.CodeModule

        Dim result
        With CodeMod
            LineNum = .CountOfDeclarationLines + 1
            Do Until LineNum >= .CountOfLines
                ProcName = .ProcOfLine(LineNum, ProcKind)
                If ProcKindString(ProcKind) = "Sub Or Function" Then
                    If IsArray(result) Then
                        ReDim Preserve result(LBound(result) To UBound(result) + 1)
                    Else
                        ReDim result(0 To 0)
                    End If
                    result(UBound(result)) = ProcName
                End If

                LineNum = .ProcStartLine(ProcName, ProcKind) + _
                        .ProcCountLines(ProcName, ProcKind) + 1
            Loop
        End With
        ListProcedures = result
    End Function

    Function ProcKindString(ProcKind As VBIDE.vbext_ProcKind) As String
        Select Case ProcKind
            Case vbext_pk_Get
                ProcKindString = "Property Get"
            Case vbext_pk_Let
                ProcKindString = "Property Let"
            Case vbext_pk_Set
                ProcKindString = "Property Set"
            Case vbext_pk_Proc
                ProcKindString = "Sub Or Function"
            Case Else
                ProcKindString = "Unknown Type: " & CStr(ProcKind)
        End Select
    End Function

' Content of Module1
Public Sub Sub1()

End Sub

Public Function Func1(ByRef x As Range)

End Function

Public Sub Sub2()

End Sub

回答2:

Okay, I'm going to do this the hard way, because I'm going to assume that you don't want to have to download the VBE classes from my repository to make this a bit easier to work with, but they're there as an example of what's possible regardless.

First, you'll need to add a reference to the Microsoft Visual Basic for Applications Extensibility 5.3 Library and allow VBA to access the editor by taking the following steps. (Assumes Office 2010)

File
Options
Trust Center
Trust Center Settings
Macro Settings
Check "Trust access to the VBA project object model".

Now we're ready to explore the code in the workbook, but first, some things to remember about what we're looking for here.

Functions
More specifically, Public Functions
In standard *.bas modules (class functions can't be UDFs).
That don't have Option Private Module

The code below works on the active vba project, but could be modified to take one as a parameter. It works with the quick test cases I provided below the Run sub, but I wouldn't guarantee that it works for all corner cases. Parsing is hard. This also just stores and prints the function signatures in the results collection. I imagine in reality you would want a function that returns them, so that you could loop through the collection looking for them in the workbook.

Option Explicit

Private Sub Run()
    Dim results As New Collection

    Dim component As VBIDE.VBComponent
    For Each component In Application.VBE.ActiveVBProject.VBComponents

        If component.Type = vbext_ct_StdModule Then
            ' find public functions with no arguments
            Dim codeMod As CodeModule
            Set codeMod = component.CodeModule

            If InStr(1, codeMod.Lines(1,codeMod.CountOfDeclarationLines), "Option Private Module") = 0 Then

                Dim lineNumber As Long
                lineNumber = codeMod.CountOfDeclarationLines + 1

                Dim procName As String
                Dim procKind As vbext_ProcKind
                Dim signature As String

                ' loop through all lines in the module
                While (lineNumber < codeMod.CountOfLines)
                    procName = codeMod.ProcOfLine(lineNumber, procKind) 'procKind is an OUT param

                    Dim lines() As String
                    Dim procLineCount As Long

                    procLineCount = codeMod.ProcCountLines(procName, procKind)
                    lines = Split(codeMod.lines(lineNumber, procLineCount), vbNewLine)

                    Dim i As Long
                    For i = 0 To UBound(lines)
                        If lines(i) <> vbNullString And Left(Trim(lines(i)), 1) <> "'" Then
                            signature = lines(i)
                            Exit For
                        End If
                    Next

                    ' this would need better parsing, but should be reasonably close
                    If InStr(1, signature, "Public Function", vbTextCompare) > 0 Then 'first make sure we have a public function
                        results.Add signature
                    End If

                    lineNumber = lineNumber + procLineCount + 1 ' skip to next procedure
                Wend

            End If

        End If
    Next component

    Dim str
    For Each str In results
        Debug.Print str
    Next
End Sub

Public Function foo()

End Function

Private Function bar()

End Function

Public Function qwaz(duck)

End Function

回答3:

I tweaked Dee's answer so that it only looks for functions. I also changed the code to search across all modules & across all worksheets in the active workbook. I also tweaked the code to highlight a cell containing a UDF when it's found. This code isn't thoroughly tested but seems to work for me. More details about my additions:

In order to restrict the search to functions, i.e. exclude subroutines, I passed the declaration line of the procedure to the ProcKindString, allowing it to distinguish between subroutines and functions. I'm working in a very large workbook with over 20 worksheets and about 30 modules where I'd say over 90% of procedures are subroutines, so this was a performance booster for me.
In order to search through all modules, I added a function which finds all modules in the current project. The function is called GetModules and returns a collection of modules. The top level function FindAllUDFs then iterates over these modules, and from there on it's pretty much Dee's code.



Option Explicit

' Add reference to Microsoft Visual Basic for Applications Extensibility 5.3 Library

Public Sub FindAllUDFs()
    Dim allModules As Collection
    Set allModules = GetModules()
    Dim module As Variant
    For Each module In allModules
        FindFunctionUsage (module)
        Next module
    End Sub

Public Sub FindFunctionUsage(moduleName As String)
    Application.StatusBar = "Looking for UDF usages in module "
    Dim udfs
    udfs = ListFunctions(moduleName)
    If Not IsArray(udfs) Then _
    Exit Sub

    Dim udf
    Dim findResult
    Dim sheet

    For Each sheet In ActiveWorkbook.Worksheets
    sheet.Activate
        For Each udf In udfs
            Application.StatusBar = "Searching... Module: " & moduleName _
            & " Sheet: " & sheet.name & " UDF: " & udf
            Set findResult = Cells.Find(What:="=" & udf, After:=Cells(1), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False)

            If Not findResult Is Nothing Then
                findResult.Activate
                MsgBox udf & " is in use"
            End If
        Next udf
    Next sheet
    Application.StatusBar = "Completed Search in " & moduleName
End Sub

    Private Function ListFunctions(moduleName As String)
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim codeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Dim NumLines As Long
        Dim WS As Worksheet
        Dim rng As Range
        Dim procName As String
        Dim procKind As VBIDE.vbext_ProcKind
        Dim procDecl As String
        Dim procDeclLine As Integer
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents(moduleName)
        Set codeMod = VBComp.CodeModule

        Dim result
        With codeMod
            LineNum = .CountOfDeclarationLines + 1
            Do Until LineNum >= .CountOfLines
                procName = .ProcOfLine(LineNum, procKind)
                procDeclLine = .procBodyLine(procName, procKind)
                procDecl = .lines(procDeclLine, 1)
                If ProcKindString(procKind, procDecl) = "Function" Then
                    If IsArray(result) Then
                        ReDim Preserve result(LBound(result) To UBound(result) + 1)
                    Else
                        ReDim result(0 To 0)
                    End If
                    result(UBound(result)) = procName
                End If

                LineNum = .ProcStartLine(procName, procKind) + _
                .ProcCountLines(procName, procKind) + 1
            Loop
        End With
        ListFunctions = result
    End Function

    Function ProcKindString(procKind As VBIDE.vbext_ProcKind, procBodyLine As String) As String
        Select Case procKind
        Case vbext_pk_Get
            ProcKindString = "Property Get"
        Case vbext_pk_Let
            ProcKindString = "Property Let"
        Case vbext_pk_Set
            ProcKindString = "Property Set"
        Case vbext_pk_Proc
            If InStr(1, procBodyLine, "Sub ", vbBinaryCompare) > 0 Then
                ProcKindString = "Sub"
            Else
                ProcKindString = "Function"
            End If
        Case Else
            ProcKindString = "Unknown Type: " & CStr(procKind)
        End Select
    End Function

    Function GetModules() As Collection
        Dim modNames As New Collection
        Dim wb As Workbook
        Dim l As Long

        Set wb = ThisWorkbook

        For l = 1 To wb.VBProject.VBComponents.Count
            With wb.VBProject.VBComponents(l)
                If .Type = 1 Then modNames.Add .name
            End With
        Next
        Set wb = Nothing
        Set GetModules = modNames

    End Function

来源：https://stackoverflow.com/questions/27711077/loop-though-all-udf-names-in-project

标签

excel

vba

excel-vba

excel-udf