AW: Aus Projekt auflisten
19.12.2009 19:12:26
Nepumuk
Hallo Claudia,
garnicht so einfach nur die Ranges auiszulesen die sich auf einen Bereichsnamen beziehen. Da gibt es nämlich nach einige andere Varianten.
Public Sub SearchString()
Const SHEET_NAME = "Prozedurliste"
Dim objModul As Object, objWorksheet As Worksheet
Dim objRegEx As Object, objMatch As Object, objMatchCollection As Object
Dim lngLine As Long, lngColumn As Long, lngRow As Long
Dim strTemp As String
Dim blnFound As Boolean
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each objWorksheet In ThisWorkbook.Worksheets
If objWorksheet.Name = SHEET_NAME Then
blnFound = True
objWorksheet.Cells.Clear
Exit For
End If
Next
If Not blnFound Then
Set objWorksheet = ThisWorkbook.Worksheets.Add
objWorksheet.Name = SHEET_NAME
End If
objWorksheet.Move Before:=ThisWorkbook.Sheets(1)
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.MultiLine = True
.Global = True
.IgnoreCase = True
.Pattern = "Range\(" & Chr$(34) & "\w+?" & Chr$(34) & "\)"
End With
lngRow = 1
With ThisWorkbook.VBProject
For Each objModul In .VBComponents
With objModul.CodeModule
lngLine = 1: lngColumn = 1
Do
If .Find("Range", lngLine, lngColumn, _
-1, -1, True, False, True) Then
If .ProcOfLine(lngLine, 3) <> "SearchString" Then
Set objMatchCollection = objRegEx.Execute( _
Trim$(objModul.CodeModule.Lines(lngLine, 1)))
For Each objMatch In objMatchCollection
strTemp = Replace(objMatch.Value, "Range(", "")
strTemp = Left$(strTemp, Len(strTemp) - 2)
strTemp = Mid$(strTemp, 2)
lngRow = lngRow + 1
objWorksheet.Cells(lngRow, 1).Value = strTemp
objWorksheet.Cells(lngRow, 2).Value = .ProcOfLine(lngLine, 3)
objWorksheet.Cells(lngRow, 3).Value = .Name
Next
End If
lngLine = lngLine + 1
Else
Exit Do
End If
Loop
End With
Next
End With
With objWorksheet.Range("A1:C1")
.Value2 = Array("Bereichsname", "Prozedurname", "Modulname")
.Font.Bold = True
.EntireColumn.AutoFit
End With
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Set objModul = Nothing
Set objWorksheet = Nothing
Set objRegEx = Nothing
Set objMatch = Nothing
Set objMatchCollection = Nothing
End Sub
Gruß
Nepumuk