Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1124to1128
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Aus Projekt auflisten

Aus Projekt auflisten
Claudia
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Aus Projekt auflisten
19.12.2009 17:52:40
Nepumuk
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
Anzeige
AW: Aus Projekt auflisten
19.12.2009 18:06:39
Claudia
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
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
Anzeige
@ Nepumuk: Vielen Dank! oT
19.12.2009 19:29:21
Claudia
Hier mal was zum spielen...
19.12.2009 18:39:39
Tino
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
Anzeige
@Tino
19.12.2009 19:42:34
Claudia
Hallo Tino,
das ist auch cool, sogar mit Zeilenangabe. Nicht schlecht.
Vielen Dank!
LG
Claudia

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige