Microsoft Excel

Herbers Excel/VBA-Archiv

Aus Projekt auflisten | Herbers Excel-Forum


Betrifft: Aus Projekt auflisten von: Claudia
Geschrieben am: 19.12.2009 16:33:41

Hallo zusammen,

gibt es eine Möglichkeit, bestimmte Codeeinträge aus dem Projekt aufzulisten?

Genauer gesagt, suche ich Zeileneinträge, die mit "Range" beginnen:

Range("Geburtsdatum").Cells(ActiveCell.Row, 1).Value = .......

Die Optimallösung wäre, diese Einträge in einem neuen Blatt aufzulisten.

Spalte A
Range("Geburtsdatum").Cells(ActiveCell.Row, 1).Value = .......

Spalte B (Ort der Zeile)
Modul "Daten auslesen"

Geht so was?

LG
Claudia

  

Betrifft: AW: Aus Projekt auflisten von: Nepumuk
Geschrieben am: 19.12.2009 17:52:40

Hallo Claudia,

ich war so frech und schreib in Spalte B den Namen der Prozedur und erst in Spalte C den Namen des Moduls.

Public Sub SearchString()
    Dim objModul As Object
    Dim lngLine As Long, lngColumn As Long, lngRow As Long
    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
                        lngRow = lngRow + 1
                        Cells(lngRow, 1).Value = Trim$(.Lines(lngLine, 1))
                        Cells(lngRow, 2).Value = .ProcOfLine(lngLine, 3)
                        Cells(lngRow, 3).Value = .Name
                        lngLine = lngLine + 1
                    Else
                        Exit Do
                    End If
                Loop
            End With
        Next
    End With
End Sub

Gruß
Nepumuk


  

Betrifft: AW: Aus Projekt auflisten von: Claudia
Geschrieben am: 19.12.2009 18:06:39

Hallo Nepumuk,

prima das klappt. Zwei Fragen hätte ich noch.

Kannst Du mir das so noch einbauen, dass immer eine neues Blatt am Anfangerzeugt wird. Hatte das Makro nämlich gestartet und wusch, war meine Zahlen in der Tabelle futsch.

Zweite Frage:

Wie müsste das Makro aussehen, was z.B. aus dem folgenden Codezeile
Range("Geburtsdatum").Cells(ActiveCell.Row, 1).Value = .......
dann in Spalte D nur noch "Geburtsdatum" einträgt?

Vielen Dank!

LG
Claudia


  

Betrifft: AW: Aus Projekt auflisten von: Nepumuk
Geschrieben am: 19.12.2009 19:12:26

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


  

Betrifft: @ Nepumuk: Vielen Dank! oT von: Claudia
Geschrieben am: 19.12.2009 19:29:21




  

Betrifft: Hier mal was zum spielen... von: Tino
Geschrieben am: 19.12.2009 18:39:39

Hallo,
kannst ja mal testen.
Erstellen ein neues Modul und kopieren den Code rein.
Schreibe bei Const aktModul$ den Namen dieses Moduls,
dieses Modul wird beim durchlauf ausgelassen.
In den Excel- Optionen muss der Zugriff auf VBA Projekte vertraut werden.

Sub Test()
Dim meAr(), A&
Dim i%, ii%, iii%
Dim sLine$

'hier angeben wo dieser Code sich befindet 
'damit dieser ausgelassen wird 
Const aktModul$ = "Modul1"

'Für Überschrift*********** 
Redim Preserve meAr(2, iii)
meAr(0, iii) = "Ort"
meAr(1, iii) = "Zeile"
meAr(2, iii) = "Code"
iii = iii + 1

With ThisWorkbook.VBProject
 For i = 1 To .VBComponents.Count
    With .VBComponents(i)
        If .Name <> aktModul Then
            For ii = 1 To .CodeModule.CountOfLines
               sLine = Application.WorksheetFunction.Clean(Trim$(.CodeModule.Lines(ii, 1)))
               If sLine Like "Range*" Then
                    Redim Preserve meAr(2, iii)
                    meAr(0, iii) = .Name
                    meAr(1, iii) = ii
                    meAr(2, iii) = sLine
                    iii = iii + 1
               End If
            Next ii
        End If
    End With
 Next i
End With

If iii > 0 Then
    With Worksheets.Add
        .Range("A1").Resize(iii, Ubound(meAr) + 1) = Application.Transpose(meAr)
        .UsedRange.Rows(1).Font.Bold = True
        .UsedRange.Cells.EntireColumn.AutoFit
    End With
End If

End Sub
Gruß Tino


  

Betrifft: @Tino von: Claudia
Geschrieben am: 19.12.2009 19:42:34

Hallo Tino,

das ist auch cool, sogar mit Zeilenangabe. Nicht schlecht.

Vielen Dank!

LG
Claudia


Beiträge aus den Excel-Beispielen zum Thema "Aus Projekt auflisten"