CODEWITHSUNDEEP
excelvba
Jack
Jack

Reputation: 733

Get the name of all Sub in Workbook

I want to get all the names of the subs in a workbook to execute if their name contains something. However I can't find the right class for doing such thing. Do you know what I should use to do something like :

Dim mdl As Module
Dim macro As macro

For Each mdl In ThisWorkbook
    For Each macro In mdl
        If Left(macro.Name, 11) = "FilterChart" Then
            Run macro
            .Chart.Export ....
        End If
Next mdl

That's the spirit of what I want to do however I don't know what to put in my loops. Does anyone know if what I want to achieve is even possible? Thank you in advance!

Upvotes: 0

Views: 903

Answers (2)

Harassed Dad
Harassed Dad

Reputation: 4714

In order to be able to programatically read details of the Visual Basic code in a worksheet you need to set the workbook to allow access to the vb code. File,Options,Advanced,Trust Center, Trust Center Settings,Macro Settings and tick "Trust Access to the VBA project model"

Then in the vb editor you need to set a reference to "Microsoft Visual Basic for Applications Extensibility" (The version number will differ depending on your installation)

You can then run this to dump the names to the immediate window (you can modify to suit)

Sub getnames()

Dim p As VBProject
Dim m As VBComponent
Dim l As Long
Dim s As String
Set p = ThisWorkbook.VBProject
For Each m In p.VBComponents
With m.CodeModule
    If .CountOfLines > 2 Then
    For l = 2 To .CountOfLines
    s = .Lines(l, 1)
    If Left(s, 4) = "Sub " Then
        Debug.Print Replace(s, "Sub ", "")
    End If

    Next l
 End If
End With
Next m
End Sub

Upvotes: 1

Mikku
Mikku

Reputation: 6664

This Piece of code does that exactly.

Sub GetProcedures()
  ' Declare variables to access the Excel workbook.
  Dim app As Excel.Application
  Dim wb As Excel.Workbook
  Dim wsOutput As Excel.Worksheet
  Dim sOutput() As String
  Dim sFileName As String

  ' Declare variables to access the macros in the workbook.
  Dim vbProj As VBIDE.VBProject
  Dim vbComp As VBIDE.VBComponent
  Dim vbMod As VBIDE.CodeModule

  ' Declare other miscellaneous variables.
  Dim iRow As Long
  Dim iCol As Long
  Dim iLine As Integer
  Dim sProcName As String
  Dim pk As vbext_ProcKind

  Set app = Excel.Application

  ' create new workbook for output
  Set wsOutput = app.Workbooks.Add.Worksheets(1)

  'For Each wb In app.Workbooks
  For Each vbProj In app.VBE.VBProjects

    ' Get the project details in the workbook.
    On Error Resume Next
    sFileName = vbProj.fileName
    If Err.Number <> 0 Then sFileName = "file not saved"
    On Error GoTo 0

    ' initialize output array
    ReDim sOutput(1 To 2)
    sOutput(1) = sFileName
    sOutput(2) = vbProj.Name
    iRow = 0

    ' check for protected project
    On Error Resume Next
    Set vbComp = vbProj.VBComponents(1)
    On Error GoTo 0

    If Not vbComp Is Nothing Then
      ' Iterate through each component in the project.
      For Each vbComp In vbProj.VBComponents

        ' Find the code module for the project.
        Set vbMod = vbComp.CodeModule

        ' Scan through the code module, looking for procedures.
        iLine = 1
        Do While iLine < vbMod.CountOfLines
          sProcName = vbMod.ProcOfLine(iLine, pk)
          If sProcName <> "" Then
            iRow = iRow + 1
            ReDim Preserve sOutput(1 To 2 + iRow)
            sOutput(2 + iRow) = vbComp.Name & ": " & sProcName
            iLine = iLine + vbMod.ProcCountLines(sProcName, pk)
          Else
            ' This line has no procedure, so go to the next line.
            iLine = iLine + 1
          End If
        Loop

        ' clean up
        Set vbMod = Nothing
        Set vbComp = Nothing

      Next
    Else
      ReDim Preserve sOutput(1 To 3)
      sOutput(3) = "Project protected"
    End If

    If UBound(sOutput) = 2 Then
      ReDim Preserve sOutput(1 To 3)
      sOutput(3) = "No code in project"
    End If

    ' define output location and dump output
    If Len(wsOutput.Range("A1").Value) = 0 Then
      iCol = 1
    Else
      iCol = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column + 1
    End If
    wsOutput.Cells(1, iCol).Resize(UBound(sOutput) + 1 - LBound(sOutput)).Value = _
        WorksheetFunction.Transpose(sOutput)

    ' clean up
    Set vbProj = Nothing
  Next

  ' clean up
  wsOutput.UsedRange.Columns.AutoFit
End Sub

I found it somewhere on a Site couple of months ago.

Upvotes: 1

Related Questions