使用VBA在“ ThisWorkbook”中的Excel工作簿中插入代碼

Question

我需要使用VBA將大量代碼插入Excel中的“ ThisWorkbook”模塊的幫助。

使用下面的代碼，我可以將代碼插入“ ThisWorkbook”模塊中，但是由於行號（＆_），這種方法（如我最近所了解的）限制為24行。

Sub AddCode()
Dim VBP As Object
Dim newmod As Object
Set VBP = ActiveWorkbook.VBProject
Set newmod = VBP.VBComponents.Add(1)
Dim StartLine As Long
Dim cLines As Long

With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
cLines = .CountOfLines + 1
    .InsertLines cLines, _
        "Private Sub Workbook_Open()" & Chr(13) & _
                "   Application.Calculation = xlManual" & Chr(13) & _
                "   Application.CalculateBeforeSave = False" & Chr(13) & _
                "   Application.DisplayFormulaBar = False" & Chr(13) & _
        "Call Module1.ProtectAll" & Chr(13) & _
        "End Sub"
End With 
End Sub

除了上面的代碼外，我想插入的代碼也在下面（在其他站點上找到的代碼）。 這使我可以跟蹤與他人共享的工作簿上的更改。 我不想使用Excel的內置“跟蹤更改”功能。

Dim vOldVal
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim bBold As Boolean

If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
    With Application
         .ScreenUpdating = False
         .EnableEvents = False
    End With
    If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
    bBold = Target.HasFormula
        With Sheet1
            .Unprotect Password:="Passcode"
                If .Range("A1") = vbNullString Then
                    .Range("A1:E1") = Array("CELL CHANGED", "OLD VALUE", _
                        "NEW VALUE", "TIME OF CHANGE", "DATE OF CHANGE")
                End If
            With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
                  .Value = Target.Address
                  .Offset(0, 1) = vOldVal
                      With .Offset(0, 2)
                        If bBold = True Then
                          .ClearComments
                          .AddComment.Text Text:= _
                               "Note:" & Chr(10) & "" & Chr(10) & _
                                  "Bold values are the results of formulas"
                        End If
                          .Value = Target
                          .Font.Bold = bBold
                      End With               
                .Offset(0, 3) = Time
                .Offset(0, 4) = Date
            End With
            .Cells.Columns.AutoFit
            .Protect Password:="Passcode"
        End With
    vOldVal = vbNullString
    With Application
         .ScreenUpdating = True
         .EnableEvents = True
    End With
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    vOldVal = Target
End Sub

我該如何實現？ 最佳和最有效的方法是什么？

我嘗試將代碼分成20行，並創建3個“ AddCode”子例程，但是在“ bBold = Target.HasFormula”處出現錯誤。 我在網上搜索了替代方法，但似乎沒有任何效果。

提前致謝。

Answer 1

這是我要創建的加載代碼的縮寫版本。 我創建onload事件，然后添加一個新模塊。

Sub AddOnload()
''Create on load sub
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
   .InsertLines 1, "Private Sub Workbook_Open()"
   .InsertLines 2, "   call CallMe"
   .InsertLines 3, "End Sub"
End With
Call CreateCode
End Sub

''Add new module with code
Sub CreateCode()
    Dim vbp As VBProject
    Dim vbc As VBComponent
    Dim strCode
    Set vbp = Application.VBE.ActiveVBProject
    Set vbc = vbp.VBComponents.Add(vbext_ct_StdModule)
    vbc.Name = "tracker"
    strCode = "Sub CallMe()" & vbCrLf & "End Sub"
    vbc.CodeModule.AddFromString strCode  
End Sub