Sub 找巨集名稱()
Application.DisplayAlerts = False
[A1] = "活頁簿名稱"
[B1] = "模組名稱"
[C1] = "程序名稱"
R = 2
Set WB = ThisWorkbook
For Each VBC In WB.VBProject.VBComponents
Select Case VBC.Type
Case 1 '1=一般模組
LS = VBC.CodeModule.CountOfLines
'Debug.Print LS
LineStr = VBC.CodeModule.Lines(1, LS)
Lines = Split(LineStr, vbCrLf)
For Each Line In Lines
If Line Like "Sub*" Then
Cells(R, 1) = WB.Name
Cells(R, 2) = VBC.Name
Cells(R, 3) = Line
R = R + 1
End If
Next 'Line
Case Else
End Select
Next 'VBC
Columns.AutoFit
End Sub作者: Scott090 時間: 2023-4-20 21:26
把 3# 樓的程式碼修改如下 測試。
Sub 找巨集名稱()
Application.DisplayAlerts = False
'[A1] = "活頁簿名稱"
'[B1] = "模組名稱"
'[C1] = "程序名稱"
R = 1 '2
ActiveSheet.Cells.Clear
Set WB = ThisWorkbook
For Each VBC In WB.VBProject.VBComponents
Select Case VBC.Type
Case 1 '1=一般模組
LS = VBC.CodeModule.CountOfLines
'Debug.Print LS
LineStr = VBC.CodeModule.Lines(1, LS)
Lines = Split(LineStr, vbCrLf)
For Each Line In Lines
Cells(R, 1) = IIf(Left(Line, 1) = "'", "'" & Line, Line) '避免備註符號 ' 在儲存格被視為一般文字格式
' If Line Like "Sub*" Then
' Cells(R, 1) = WB.Name
' Cells(R, 2) = VBC.Name
' Cells(R, 3) = Line
R = R + 1
' End If
Next 'Line
Case Else
End Select
Next 'VBC
Columns.AutoFit
End Sub作者: Andy2483 時間: 2023-4-21 15:04
Private Sub GetModules()
Dim wb As Workbook, sh As Worksheet
Dim k&, RowNum%, c
Dim VBC, CodeStrs
Dim arrProc$(), arrB
Set wb = ThisWorkbook
Set sh = Sheets("MacroList") '程序調用工作表
sh.Cells.Clear
sh.Select
Range("A1").Select
Set VBC = wb.VBProject.VBComponents
RowNum = 0
ReDim arrProc(5, 1)
For Each c In VBC
RowNum = ListProcedures(c.CodeModule.Name, RowNum, arrProc)
Next
'凍結第一列 欄位名稱
Range("A2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
[A2].Resize(RowNum, 5) = Application.Transpose(arrProc)
Set wb = Nothing
End Sub
Function ListProcedures(ModuleName$, RowNum%, arrProc) As Integer
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum&, lineStr$, CodeStrs, startLineNum&, endLineNum&
Dim ProcLineCount&, LS&
Dim sh As Worksheet
Dim Rng As Range
Dim ProcName As String
Dim ProcKind As vbext_ProcKind '程序種類 modules, sub( ) or function( ),property get,property Let, property set
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents(ModuleName) 'VBComp 是 模組名稱內的元件
Set CodeMod = VBComp.CodeModule
Set sh = ActiveWorkbook.Worksheets("MacroList") '設定一調用表的工作表
sh.Select
LS = CodeMod.CountOfLines '這個模組內(所有的程序)程式碼語句的行數
'有模組名但沒有程序碼則跳過
If LS = 0 Then GoTo ExitFunction
' Cells(RowNum + 1, "D") = startLineNum & ", " & ProcLineCount
LineNum = startLineNum + ProcLineCount + 1 '同一模組之下一個程序開始行碼 程序開始數 + 程序長度
Loop
End With
ExitFunction:
ListProcedures = RowNum
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
'參考 Searching For Text In A Module http://www.cpearson.com/excel/vbe.aspx
Sub 程序調用表(arrProc) '(FindWhat$) '搜尋 調用的子程序與函數名稱字串
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponents
Dim VBC 'As Object
Dim CodeMod As VBIDE.CodeModule
Dim ProcName As String
Dim ButtonStr$ '自訂另列 Command Bar 按鈕字串
Dim ProcKind As VBIDE.vbext_ProcKind '程序種類 modules, sub( ) or function( ),property get,property Let, property set
Dim wb As Workbook
Dim lineStr$, CodeStrs, Proc
Dim i&, j&, RowNum&, comma$
Dim SL&, SL0& ' start line
Dim EL& ' end line
Dim SC&, SC0& ' start column
Dim EC&, EC0& ' end column
Dim Found As Boolean
'引用項： Microsoft Visual Basic for Applications Extensibility 5.3
' AddExtenReference '加入引用項
Set wb = ThisWorkbook
Set VBProj = wb.VBProject
Set VBComp = VBProj.VBComponents '(ModuleNames)
For i = 1 To UBound(arrProc, 2)
' Debug.Print arrProc(2, i)
comma = ""
For Each VBC In VBComp
Set CodeMod = VBC.CodeModule
With CodeMod
'在同一模組內反覆搜尋
Do Until Found = False
If SL = Split(arrProc(4, i), ",")(0) Then GoTo 101 '找到的是程序或函數定義本身的名稱
lineStr = Trim(Left(.Lines(SL, 1), SC - 1)) '找到的字串前面的字串
'自訂另列Command Bar 按鈕字串
If InStr(lineStr, "OnAction =") <> 0 Then
ButtonStr = ". " & Replace(Mid(Trim(.Lines(SL - 1, 1)), 12), Chr(34), "") 'len(".caption = ") =11
GoTo 100
End If
' 字串有 "' "、"Sub"、 "Function"、 ' "'則找到的字串可能不是在呼叫程序或是程序頭
If InStr(lineStr, Chr(39)) <> 0 Or _
InStr(lineStr, "Sub") <> 0 Or _
InStr(lineStr, "Function") Or _
Right(lineStr, 1) = Chr(34) Then GoTo 101
100
ProcName = .ProcOfLine(SL, ProcKind) '搜尋到的字串在那個子程序或函數
If ProcName <> arrProc(2, i) Then
arrProc(5, i) = arrProc(5, i) & comma & .Name & "." & ProcName & ButtonStr
comma = ", ": ButtonStr = ""
End If
'在找到字串的同一行的下一個字繼續搜尋
EL = .CountOfLines
SC = EC: EC = 1023
GoTo 102
101
'從下一行的起始列繼續搜尋
SL0 = SL: SL = SL + 1
SC0 = 0: SC = 0
EC0 = 0: EL = .CountOfLines
EC = 1023 '最多一字串之限定長度 1023個字
102
Found = .Find(Target:=arrProc(2, i), startline:=SL, StartColumn:=SC, _
EndLine:=EL, EndColumn:=EC, _
wholeword:=True, MatchCase:=True, patternsearch:=False)
Loop
End With
next_VBC:
Next 'Module
Next_i:
Next 'i ,next Procedure being called
