AW: Noch zwei Wünsche
Tino
Hallo,
ok teste mal ob so bei Dir geht.
Option Explicit
Sub MakroListe()
Dim vbc As Object, iRow As Integer, iCol As Integer, iCounter As Integer, sMacro As String
Dim sMakroCode As String
Dim myWB As Workbook, aktivSH As Worksheet
Dim LLetzte As Long
Dim objCom As Comment
Set aktivSH = ThisWorkbook.Worksheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
On Error Resume Next
LLetzte = aktivSH.Cells.Find("*", , xlValues, 2, 1, 2, False, False, False).Row
On Error GoTo 0
LLetzte = IIf(LLetzte = 0, 1, LLetzte + 2)
For Each myWB In Workbooks
If myWB.Name <> ThisWorkbook.Name Then Exit For
Next myWB
aktivSH.Rows(LLetzte).Font.Bold = True
aktivSH.Cells(LLetzte, 1).Value = "Datei- Name"
aktivSH.Cells(LLetzte + 1, 1).Value = myWB.Name
iCol = 1
For Each vbc In myWB.VBProject.VBComponents
iRow = LLetzte
iCol = iCol + 1
aktivSH.Cells(iRow, iCol).Value = vbc.Name
With vbc.CodeModule
For iCounter = 1 To .CountOfLines
If .ProcOfLine(iCounter, 0) > "" Then
sMacro = .ProcOfLine(iCounter, .CountOfLines)
If sMacro <> aktivSH.Cells(iRow, iCol) Then
sMakroCode = .Lines(iCounter, .CountOfLines)
If sMakroCode Like "*End Sub*" Then
sMakroCode = Left$(sMakroCode, InStr(sMakroCode, "End Sub") + 6)
End If
If sMakroCode Like "*End Function*" Then
sMakroCode = Left$(sMakroCode, InStr(sMakroCode, "End Function") + 11)
End If
iRow = iRow + 1
aktivSH.Cells(iRow, iCol).Value = sMacro
'Kommentar erstellen
If sMakroCode <> "" Then
sMakroCode = Trim$(sMakroCode)
Set objCom = aktivSH.Cells(iRow, iCol).AddComment(sMakroCode)
objCom.Shape.DrawingObject.AutoSize = True
sMakroCode = ""
End If
End If
End If
Next iCounter
End With
Next vbc
aktivSH.Columns.AutoFit
End Sub
Gruß Tino