If ActiveWorkbook.VBProject.Protection = 1 Then 'vbext_pp_locked 
   MsgBox "VBProject защищён", , "" 
Else 
   MsgBox "VBProject не защищён", , "" 
End If

Application.VBE.ActiveVBProject.Name = "VBAProject_New"

Application.VBE.VBProjects(3).Name = "VBAProject_New"

Application.VBE.VBProjects("VBAProject").Name = "VBAProject_New"

ActiveWorkbook.VBProject.Name = "VBAProject_New" 

ThisWorkbook.VBProject.Name = "VBAProject_New"

Workbooks("Personal.xls").VBProject.Name = "VBAProject_New"

Application.VBE.ActiveVBProject.VBComponents(4).Name = "Module" 

Application.VBE.ActiveVBProject.VBComponents("Module").Name = "New"

ActiveWorkbook.VBProject.VBComponents(4).Name = "Module" 

ActiveWorkbook.VBProject.VBComponents("Module").Name = "New"

With Application.VBE.SelectedVBComponent 
     If .CodeModule.CountOfLines <> 0 Then 
        .CodeModule.DeleteLines 1, .CodeModule.CountOfLines 
     End If 
End With ' (а)

With ActiveWorkbook.VBProject.VBE.SelectedVBComponent 
     If .CodeModule.CountOfLines <> 0 Then 
        .CodeModule.DeleteLines 1, .CodeModule.CountOfLines 
     End If 
End With ' (б)

Set iVBComponent = Application.VBE.SelectedVBComponent 

iCountOfLines = iVBComponent.CodeModule.CountOfLines 

If iCountOfLines <> 0 Then 
   iVBComponent.CodeModule.DeleteLines 1, iCountOfLines 
End If

Private Sub DeleteProcedure() 
    iProcedure$ = InputBox(Prompt:="Введите имя макроса," & _ 
    vbCrLf & "который требуется удалить", Title:="") 
    If iProcedure$ = "" Then _ 
    MsgBox "Вы не указали имя ненужного макроса", , "": Exit Sub 
    For Each iVBComponent In ActiveWorkbook.VBProject.VBComponents 
        With iVBComponent.CodeModule 
             If .Find("Sub " & _ 
                iProcedure$, 1, 1, .CountOfLines, 1) = True Then 
                iStartLine& = .ProcStartLine(iProcedure$, 0) 
                iCountLines& = .ProcCountLines(iProcedure$, 0) 
                .DeleteLines iStartLine&, iCountLines& : Exit For 
             End If 
        End With 
    Next 
End Sub

With ActiveWorkbook.VBProject.VBComponents 
     If .Item(5).Type Like "[1-3]" Then 
        .Remove .Item(5) 
     End If 
End With ' (а)

With Application.VBE.ActiveVBProject.VBComponents 
     If .Item(5).Type Like "[1-3]" Then 
        .Remove .Item(5) 
     End If 
End With ' (б)

Private Sub DeleteModulesAndCode()
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        With iVBComponent
             Select Case .Type
                 Case 1 To 3: .Collection.Remove iVBComponent
                 Case 100: .CodeModule.DeleteLines _
                 1, .CodeModule.CountOfLines
             End Select
        End With
    Next
End Sub

Private Sub DeleteModulesAndCode2()
    Set iVBComponents = ThisWorkbook.VBProject.VBComponents
    For Each iVBComponent In iVBComponents
        Select Case iVBComponent.Type
            Case 1 To 3: iVBComponents.Remove iVBComponent
            Case 100
            With iVBComponent.CodeModule
                 .DeleteLines 1, .CountOfLines
            End With
        End Select
    Next
End Sub

Private Sub DeleteModulesAndCode3()
    With ThisWorkbook.VBProject.VBComponents
         For iCount& = .Count To 1 Step -1
             Set iVBComponent = .Item(iCount&)
             Select Case iVBComponent.Type
                 Case 1 To 3: .Remove iVBComponent
                 Case 100
                 iVBComponent.CodeModule.DeleteLines _
                 1, iVBComponent.CodeModule.CountOfLines
             End Select
        Next
    End With
End Sub

Private Sub DeleteOnlyUserForms()
    With ThisWorkbook.VBProject.VBComponents
         For iCount& = .Count To 1 Step -1
             If .Item(iCount&).Type = 3 Then .Remove .Item(iCount&)
         Next
    End With
End Sub

Private Sub DeleteOnlyUserForms2()
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        If iVBComponent.Type = 3 Then _
        iVBComponent.Collection.Remove iVBComponent
    Next
End Sub

Private Sub DeleteOnlyUserForms2v2()
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        If iVBComponent.Type = 3 Then _
        ThisWorkbook.VBProject.VBComponents.Remove iVBComponent
    Next
End Sub

Private Sub DeleteOnlyUserForms2v3()
    Set iVBComponents = ThisWorkbook.VBProject.VBComponents
    For Each iVBComponent In iVBComponents
        If iVBComponent.Type = 3 Then iVBComponents.Remove iVBComponent
    Next
End Sub

ActiveWorkbook.VBProject.VBComponents(1).CodeModule.InsertLines 1, "Option Explicit"

ActiveWorkbook.VBProject.VBComponents(1).CodeModule.InsertLines 5, _ 
"Dim iText as String, iColumn As Integer" & vbNewLine & _ 
"iText = ""Microsoft Excel""" & vbNewLine & _ 
"iColumn = [Имя_ячейки].Column"

ActiveWorkbook.VBProject.VBComponents(1).CodeModule.ReplaceLine 1, "Private Sub Workbook_Activate()"

ActiveWorkbook.VBProject.VBComponents(1).CodeModule.DeleteLines 1 
'ActiveWorkbook.VBProject.VBComponents(1).CodeModule.DeleteLines 1, 1

ActiveWorkbook.VBProject.VBComponents(1).CodeModule.DeleteLines 3, 10

iCountOfLines = ActiveWorkbook.VBProject.VBComponents(1).CodeModule.CountOfLines

iCountOfDeclareLines = _
ActiveWorkbook.VBProject.VBComponents(1).CodeModule.CountOfDeclarationLines

Private Sub SearchTextInModules()
    iText$ = "Private Sub"
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        With iVBComponent.CodeModule
             If .Find(iText$, 1, 1, .CountOfLines, 1) = True Then _
             MsgBox "Модуль " & iVBComponent.Name & " содержит искомый текст", , ""
        End With
    Next
End Sub

Private Sub ReplaceTextInModulesV2()
    For Each iVBComponent In Workbooks("Другая_книга.xls").VBProject.VBComponents
        With iVBComponent.CodeModule
             iRow& = 1
             Do While .Find("Private", iRow&, 1, .CountOfLines, 1) 'Do Until Not
                .ReplaceLine iRow&, Replace(.Lines(iRow&, 1), "Private", "Public", , , vbTextCompare)
             Loop
        End With
    Next
End Sub

Private Sub ReplaceTextInModules()
    Dim iVBComponent As Object, iRow&, iText$, iNewText$
    iText = Chr(80) & "rivate": iNewText = "Public"
    
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        With iVBComponent.CodeModule
             iRow = 1
             Do While .Find(iText, iRow, 1, .CountOfLines, 1) 'Do Until Not
                .ReplaceLine iRow, _
                Replace(.Lines(iRow, 1), iText, iNewText, , , vbTextCompare)
             Loop
        End With
    Next
End Sub

Public Sub ReplaceTextInModulesV3()
    Dim iVBComponent As Object, iCount&, iCode$, iText$, iNewText$
    iText = Chr(80) & "rivate": iNewText = "Public"
    
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents
        With iVBComponent.CodeModule
             iCount = .CountOfLines
             If iCount > 0 Then
                iCode = Replace(.Lines(1, iCount), iText, iNewText)
                .DeleteLines 1, iCount: .InsertLines 1, iCode
             End If
        End With
    Next
End Sub

Private Sub FindSubMacros()
    Application.ScreenUpdating = False
    Workbooks.Add xlWBATWorksheet: iRow& = 1
    Dim iWorkbook  As Workbook
    Dim iVBProject   As Object
    Dim iVBComponent As Object
    For Each iWorkbook In Workbooks
        Set iVBProject = iWorkbook.VBProject
        If Not iVBProject.Protection = 1 Then 'vbext_pp_locked
           For Each iVBComponent In iVBProject.VBComponents
               iStart& = 1
               With iVBComponent.CodeModule
                    Do Until Not .Find("Sub ", iStart&, 1, .CountOfLines, 1, , True)
                       iStart& = iStart& + 1: iRow& = iRow& + 1
                       Cells(iRow&, 1).Value = iWorkbook.Name
                       Cells(iRow&, 2).Value = iVBProject.Name
                       Cells(iRow&, 3).Value = iVBComponent.Name
                       Cells(iRow&, 4).Value = .ProcOfLine(iStart&, 0)
                    Loop
               End With
           Next
        Else
           iRow& = iRow& + 1
           Cells(iRow&, 1).Value = iWorkbook.Name
           Cells(iRow&, 2).Value = iVBProject.Name & " (заблокирован)"
        End If
    Next
    With Cells(1, 1).Resize(1, 4) 'Range("A1:D1")
         .Value = Array("Workbook", "VBProject", "Module", "Sub_Macros")
         .Interior.Color = vbBlack
         .Font.Color = vbWhite
         .Font.Bold = True
         .EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub VBProjectTreeView()
    With ThisWorkbook.VBProject
         If .Protection = 1 Then Exit Sub 'vbext_pp_locked
         For Each iVBComponent In .VBComponents
             'iModule = iVBComponent.Name
             With iVBComponent.CodeModule
                  iModule$ = .Parent.Name
                  TreeView1.Nodes.Add , , iModule$, iModule$
                  For iCount& = 1 To .CountOfLines
                      iProcedure$ = .ProcOfLine(iCount&, 0) 'vbext_pk_Proc
                      If iProcedure$ <> "" Then
                         TreeView1.Nodes.Add iModule$, 4, , iProcedure$
                         iCount& = iCount& + .ProcCountLines(iProcedure$, 0)
                      End If
                  Next
             End With
         Next
    End With
End Sub

Private Sub ExportAllStdModules() 
    With Application 
         .ScreenUpdating = False 
         iTempPath$ = .DefaultFilePath & .PathSeparator 
         With .Workbooks.Add(xlWBATWorksheet).VBProject.VBComponents 
              For Each iVBComponent In ThisWorkbook.VBProject.VBComponents 
                  If iVBComponent.Type = 1 Then 
                     iModuleName$ = iTempPath$ & iVBComponent.Name 
                     iVBComponent.Export FileName:=iModuleName$ 
                     .Import FileName:=iModuleName$ 
                     Kill PathName:=iModuleName$ 
                  End If 
              Next 
         End With 
         .ScreenUpdating = True 
    End With 
End Sub

Private Sub ExportAllVBComponents() 
    iTempPath$ = Environ("Temp") & "\" 'укажите свою папку 
    For Each iVBComponent In ThisWorkbook.VBProject.VBComponents 
        Select Case iVBComponent.Type 
            Case 1: iType$ = ".bas" 
            Case 3: iType$ = ".frm" 
            Case 2, 100: iType$ = ".cls" 
        End Select 
        iVBComponent.Export _ 
        FileName:=iTempPath$ & iVBComponent.Name & iType$ 
    Next 
End Sub

iCodeName = Worksheets(1).CodeName

iCodeName = ActiveSheet.CodeName 

ActiveWorkbook.VBProject.VBComponents(iCodeName).Name = "CodeName" ' Вариант I(а). 

Application.VBE.ActiveVBProject.VBComponents(iCodeName).Name = "CodeName" ' Вариант I(б).

Dim iList As Worksheet 
Set iList = Worksheets(1) 'ActiveSheet 

iList.[_CodeName] = "CodeName"

Dim iWorksheet As Worksheet 
Set iWorksheet = Лист2

With Лист2 

End With

Лист2.[A1:C3].Clear

Лист2.[A1,A3,B2,C1,C3].Formula = "=Rand()" 

Лист2.[A1:C3].SpecialCells(xlBlanks).Interior.Color = vbRed

With Лист2 
     .[A1:C3].Clear 
     .[A1,A3,B2,C1,C3].Formula = "=Rand()" 
     .[A1:C3].SpecialCells(xlBlanks).Interior.ColorIndex = 3 
End With

Dim iVBComponent As Object 
Dim iDiapazon As Range, iWorksheet As Worksheet 

iCodeName$ = "Лист2" 

Set iVBComponent = ThisWorkbook.VBProject.VBComponents(iCodeName$) 
Set iDiapazon = iVBComponent.Properties("Cells").Object 
Set iWorksheet = iDiapazon.Worksheet '.Parent

Dim iVBComponent As Object 
Dim iDiapazon As Range, iWorksheet As Worksheet 

iCodeName$ = "Лист2" 

Set iVBComponent = ThisWorkbook.VBProject.VBComponents(iCodeName$) 
Set iWorksheet = ThisWorkbook.Worksheets(iVBComponent.Properties("Name").Value) 
Set iDiapazon = iWorksheet.Cells

Public Function getSheetWithCodeName(CodeName$, SourceNames As Object) As Object 
    Dim iList As Object 
    For Each iList In SourceNames 
        If StrComp(iList.CodeName, CodeName, vbTextCompare) = 0 Then 
           Set getSheetWithCodeName = iList 
           Exit Function 
        End If 
    Next 
End Function

Private Sub Add_And_SynchronizeName() 
    iNewName$ = "Archive" 'укажите своё имя листа 
    With ThisWorkbook 
         If Not .ProtectStructure Then 
            .Worksheets.Add.Name = iNewName$ 
            With .VBProject.VBComponents 
                 .Item(.Count).Name = iNewName$ 
            End With 
         Else 
            MsgBox "В рабочей книге : " & .Name & vbCrLf & _ 
            "невозможно создание нового листа", vbCritical, "" 
         End If 
    End With 
End Sub

Private Sub Add_And_SynchronizeName2() 
    iNewName$ = "Archive2" 'укажите своё имя листа 
    With ThisWorkbook 
         If Not .ProtectStructure Then 
            Dim iWorksheet As Worksheet 
            Set iWorksheet = .Worksheets.Add 
            iWorksheet.Name = iNewName$ 

            Dim iVBComponents As Object 
            Set iVBComponents = .VBProject.VBComponents 
            iVBComponents(iWorksheet.CodeName).Name = iNewName$ 
         Else 
            MsgBox "В рабочей книге : " & .Name & vbCrLf & _ 
            "невозможно создание нового листа", vbCritical, "" 
         End If 
    End With 
End Sub

Workbooks.Add xlWBATWorksheet 

For Each iVBComponent In ThisWorkbook.VBProject.VBComponents 
    iCountOfLines = iVBComponent.CodeModule.CountOfLines 
    If iCountOfLines > 0 Then 
       iText = Application.Clean(Left( _ 
       iVBComponent.CodeModule.Lines(1, iCountOfLines), 32767)) 
       If iText <> "" And iText <> "Option Explicit" Then 
          iCounter = iCounter + 1 
          Cells(iCounter, 1).Value = iVBComponent.Name 
       End If 
    End If 
Next

Private Sub GetTextCodeModule()
    iModule = "Модуль1" ' iModule = 5
    With ThisWorkbook.VBProject.VBComponents(iModule).CodeModule
         If .CountOfLines = 0 Then
            MsgBox "Модуль " & iModule & " не содержит кода", , ""
         Else
            iText$ = .Lines(1, .CountOfLines)
            MsgBox iText$, , ""
            
            iCleanText$ = _
            Application.Clean(Left(.Lines(1, .CountOfLines), 32767))
            If iCleanText$ <> "" And iCleanText$ <> "Option Explicit" _
            Then MsgBox iText$, , ""
         End If
    End With
End Sub

Application.Goto Reference:="Модуль1.Тест"

ActiveWorkbook.FollowHyperlink "#Модуль1.Тест"

ActiveWorkbook.FollowHyperlink ActiveWorkbook.FullName, "Модуль1.Тест"

With ActiveWorkbook
     .FollowHyperlink .FullName, "Модуль1.Тест"
End With

Application.VBE.MainWindow.Visible = True

Application.VBE.MainWindow.WindowState = 2 'vbext_ws_Maximize

Option Compare Text 

Private Sub VBProject_AddReference()
    iPath$ = Environ("WinDir") 
    iFileName$ = iPath$ & "\System\Scrrun.dll" '[1] Win 98, Me 
    'iFileName$ = iPath$ & "\System32\Scrrun.dll" '[2] Win 2000, XP 

    If Dir(iFileName$) <> "" Then 
       With ThisWorkbook.VBProject.References 
            For iCount% = 1 To .Count 
                If .Item(iCount%).FullPath = iFileName$ Then 
                   MsgBox "Эта библиотека уже подключена", , "" 
                   Exit Sub 
                End If 
            Next 
            .AddFromFile FileName:=iFileName$ 
       End With 
    Else 
       MsgBox "Отсутствует нужный файл", , "" 
    End If
End Sub

Private Sub VBProject_AddReference2() 
    iFileName$ = Environ("WinDir") & "\System\Scrrun.dll" '[1] Win 98, Me 
    'iFileName$ = Environ("WinDir") & "\System32\Scrrun.dll" '[2] Win 2000, XP 

    If Dir(iFileName$) <> "" Then 
       Dim iReference As Object, iReferences As Object ' Variant 
       'Dim iReference As VBIDE.Reference, iReferences As VBIDE.References 
       'Если подключена библиотека : 
       'Microsoft Visual Basic for Applications Extensibility x.x 
       Set iReferences = ThisWorkbook.VBProject.References 
       For Each iReference In iReferences 
           If StrComp(iReference.FullPath, iFileName$, vbTextCompare) = 0 Then 
              MsgBox "Эта библиотека уже подключена", , "" 
              Exit Sub 
           End If 
       Next 
       iReferences.AddFromFile FileName:=iFileName$ 
    Else 
       MsgBox "Отсутствует нужный файл", , "" 
    End If
End Sub

Private Sub VBProject_RemoveMissingRef() 
    Dim iCount% ' iCount As Integer 
    With ThisWorkbook.VBProject.References 
         For iCount = .Count To 1 Step -1 
             If .Item(iCount).IsBroken = _ 
             True Then .Remove .Item(iCount) 
         Next 
    End With 
End Sub

Private Sub VBProject_RemoveMissingRef2() 
    Dim iReferences As Object, iReference As Object ' Variant 
    'Dim iReferences As VBIDE.Reference, iReference As VBIDE.References 
    'Если подключена библиотека : 
    'Microsoft Visual Basic for Applications Extensibility x.x 
    Set iReferences = ThisWorkbook.VBProject.References 
    For Each iReference In iReferences 
        If iReference.IsBroken = True _ 
        Then iReferences.Remove iReference 
    Next 
End Sub

Private WithEvents iRefEvents As VBIDE.ReferencesEvents 
'Следующая библиотека обязательно должна быть подключена 
'Microsoft Visual Basic for Applications Extensibility x.x 

Private Sub Workbook_Open() 
    Set iRefEvents = _ 
    Application.VBE.Events.ReferencesEvents(Me.VBProject) 
End Sub 

Private Sub iRefEvents_ItemAdded(ByVal Reference As VBIDE.Reference) 
    MsgBox "Добавлена ссылка : " & Reference.Name & _ 
    vbCrLf & Reference.FullPath, , "" 
End Sub 

Private Sub iRefEvents_ItemRemoved(ByVal Reference As VBIDE.Reference) 
    MsgBox "Удалена ссылка : " & Reference.Name & _ 
    vbCrLf & Reference.FullPath, , "" 
End Sub

Private WithEvents iCommandBarEvent As VBIDE.CommandBarEvents 
'Следующая библиотека обязательно должна быть подключена 
'Microsoft Visual Basic for Applications Extensibility x.x 

Private Sub Workbook_Open() 
    With Application.VBE 
         Set iCommandBarEvent = .Events.CommandBarEvents(.CommandBars("Tools").Controls(1)) 
    End With 
End Sub 

Private Sub iCommandBarEvent_Click( _
    ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean) 
    CancelDefault = True 
End Sub