Question

我需要帮助才能将相当大的代码插入＆＃34; ThisWorkbook＆＃34; Excel中的模块使用VBA。

使用下面的代码，我可以将代码插入＆＃34; ThisWorkbook＆＃34;模块，但这种方法（我最近学到的）由于线喙（＆amp; _）而限制了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内置的＆＃34; Track Changes＆＃34;特征

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＆＃34; AddCode＆＃34;子程序，但我在＆＃34; bBold = Target.HasFormula＆＃34;时收到错误。我在网上搜索了替代方案，但似乎没有任何工作。

提前致谢。

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

在Excel工作簿中插入代码＆＃34; ThisWorkbook＆＃34;使用VBA

1 个答案: