问题描述
我正在编写一个宏，它将多个表单合并为一个宏，然后以编程方式向新的合并文件中添加“ 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 (将#修改为@）