如何解决VBE-新代码未附加到目标工作簿
我正在编写一个宏,它将多个表单合并为一个宏,然后以编程方式向新的合并文件中添加“ BeforeRightClick”方法。
除了将代码添加到新工作簿中而不是将代码添加到新工作簿中之外,该代码大部分都有效,它会创建幻影副本并将代码添加到其中。这个鬼文件似乎在任何地方都不存在。
我尝试强迫它首先激活工作簿,并且将其附加为方法,将方法直接拼接为主要方法。似乎什么都没有。
注释:
- 我用于这些工作簿的文件格式是XLSB
- 我用来做这个的来源是here:
- 勾选了“ Microsoft Visual Basic for Applications Extensibility 5.3库”。
相关代码部分:
With New_WB
Set xPro = .VBProject
Set xCom = xPro.VBComponents(New_WB.Sheets("Reorder Level Form").CodeName)
Set xMod = xCom.codemodule
With xMod
xLine = .CreateEventProc("BeforeRightClick","Worksheet")
xLine = xLine + 1
.InsertLines xLine," a = Cells(ActiveCell.Row,22).Value"
xLine = xLine + 1
.InsertLines xLine," i = 1"
xLine = xLine + 1
.InsertLines xLine," For Each c In Selection"
xLine = xLine + 1
.InsertLines xLine," If Cells(c.Row,22).Offset(0,-21).Value <> """" Then"
xLine = xLine + 1
.InsertLines xLine," With Cells(c.Row,22)"
xLine = xLine + 1
.InsertLines xLine," Select Case a"
xLine = xLine + 1
.InsertLines xLine," Case False"
xLine = xLine + 1
.InsertLines xLine," .Value = True"
xLine = xLine + 1
.InsertLines xLine," Case Else"
xLine = xLine + 1
.InsertLines xLine," .Value = False"
xLine = xLine + 1
.InsertLines xLine," End Select"
xLine = xLine + 1
.InsertLines xLine," End With"
xLine = xLine + 1
.InsertLines xLine," End If"
xLine = xLine + 1
.InsertLines xLine," If i >= 1000 Then Exit Sub"
xLine = xLine + 1
.InsertLines xLine," i = i + 1"
xLine = xLine + 1
.InsertLines xLine," Next c"
xLine = xLine + 1
.InsertLines xLine," Cancel = True"
End With
With .Sheets("Reorder Level Form")
.Columns("B:B").Delete Shift:=xlToLeft
.Columns("D:F").ColumnWidth = 8
.Columns("I:I").ColumnWidth = 6
.Columns("K:K").ColumnWidth = 13
.Columns("L:M").ColumnWidth = 9
.Columns("N:P").ColumnWidth = 17
.Columns("P:Q").ColumnWidth = 10
.Columns("R:V").ColumnWidth = 12
With .Rows("1:1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.Addindent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.RowHeight = 45
End With
End With
End With
完整方法:
Sub Compiler()
Dim Header() As Variant
Dim Data() As Variant
Dim ws As Worksheet
Dim rngOutput As Range
Dim xPro As VBIDE.VBProject
Dim xCom As VBIDE.VBComponent
Dim xMod As VBIDE.codemodule
Dim xLine As Long
Dim strFilename As String
strFilename = ThisWorkbook.Sheets("Settings").Range("B1").Value & "\Stock Level Converter\Stock Level Change Extract " & Format(Now,"dd-mm-yy hhmm") & ".xlsb"
totWB = 0
totWB = Count_WB
n = 0
Hd_Row = Head_Row
Set New_WB = Workbooks.Add
New_WB.SaveAs strFilename,FileFormat:=50
dirWB = Dir(ThisWorkbook.Sheets("Settings").Range("B1").Value & "\Stock Level Converter\Import Files\")
'--------------------------------------------------
While dirWB <> ""
'Opens current file for import and saves it as a back up
Set External_WB = Workbooks.Open(ThisWorkbook.Sheets("Settings").Range("B1").Value & "\Stock Level Converter\Import Files\" & dirWB)
ChkAutoSv
strBackup = ThisWorkbook.Sheets("Settings").Range("B1").Value & "\Stock Level Converter\Import Back Ups\" & Format(Now,"yyyymmddhhmmss")
External_WB.SaveAs strBackup,xlExcel12
Deletes old copy
Kill ThisWorkbook.Sheets("Settings").Range("B1").Value & "\Stock Level Converter\Import Files\" & dirWB
frmMenu.lblStatus.Value = "Task: " & dirWB
frmMenu.Repaint
'DoEvents
For Each External_WS In Worksheets
If External_WS.Name = "Reorder Level Form" Then
'If External_WS.Visible = xlSheetVisible Then"
lst_Col = 27 'Last_Col 'the last used column in the current import file
With External_WS
.Activate
If .Range("B1").Value <> "CONC" Then
.Columns("B:B").Insert Shift:=xlToLeft
End If
.Columns(27).EntireColumn.Insert Shift:=xlRight
.Cells(Hd_Row,27).Value = "Store No."
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.Cells.UnMerge
For i = Hd_Row + 1 To Last_Row(1)
Cells(i,27).Value = .Cells(2,3).Value
Next i
'Assigns data in header row to array
Header = .Range(Cells(Hd_Row,1),Cells(Hd_Row,27)).Value2
'Assigns data to array
Data = .Range(Cells(Hd_Row + 1,Cells(Last_Row(1),27)).Value2
End With
'Checks sheet exists in new file
If WorksheetExists(External_WS.Name) = False Then
'Worksheet does not exist in New File
'Create new sheet and name it.
New_WB.Sheets.Add.Name = External_WS.Name
'Paste header array to cell(1,1)
Set rngOutput = New_WB.Sheets(External_WS.Name).Range("A1")
rngOutput.Resize(UBound(Header,UBound(Header,2)) _
= Header
End If
'Paste Data to column A of last used row + 1
r = Last_Row(2) + 1
Set rngOutput = New_WB.Sheets(External_WS.Name).Cells(r,1)
rngOutput.Resize(UBound(Data,UBound(Data,2)) _
= Data
End If
Next External_WS
With External_WB
.Close SaveChanges:=False
End With
'DoEvents
dirWB = Dir()
Wend
With New_WB
Set xPro = .VBProject
Set xCom = xPro.VBComponents(New_WB.Sheets("Reorder Level Form").CodeName)
Set xMod = xCom.codemodule
With xMod
xLine = .CreateEventProc("BeforeRightClick"," Cancel = True"
End With
With .Sheets("Reorder Level Form")
.Columns("B:B").Delete Shift:=xlToLeft
.Columns("D:F").ColumnWidth = 8
.Columns("I:I").ColumnWidth = 6
.Columns("K:K").ColumnWidth = 13
.Columns("L:M").ColumnWidth = 9
.Columns("N:P").ColumnWidth = 17
.Columns("P:Q").ColumnWidth = 10
.Columns("R:V").ColumnWidth = 12
With .Rows("1:1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.Addindent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.RowHeight = 45
End With
End With
End With
New_WB.Save
New_WB.Close,True
ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
End Sub
谢谢。
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。