请问一下各位老师~~我这段代码存在什么问题,为什么点击按钮之后无反应~
Implements IDTExtensibility2Option Explicit
Private WithEvents objButton1 As
Public xlApp As Excel.Application
Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
Set xlApp = Application
CreateMenus
End Sub
Private Sub IDTExtensibility2_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
End Sub
Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant)
End Sub
Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant)
End Sub
Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant)
End Sub
Private Sub IDTExtensibility_OnStartupComplete(custom() As Variant)
End Sub
Private Sub CreateMenus() '创建自定义工具栏
On Error Resume Next
("Worksheet Menu Bar").Controls("自定义工具(&K)").Delete
With ("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Before:=11) '创建一个新工具栏
.Caption = "自定义工具(&K)"
.Style = msoButtonIconAndCaption
Set objButton1 = .Controls.Add(Type:=msoControlButton) '创建按钮
With objButton1 '引用子菜单
.Caption = "分离" '设置菜单的显示文字
.Style = msoButtonIconAndCaption '同时显示文字与图标
.FaceId = 310 '指定图标
End With
xlApp.ScreenUpdating = True
.Visible = True
End With
End Sub
Public Sub objButton1_Click(ByVal Ctrl As , CancelDefault As Boolean)
分离
End Sub
Public Sub 分离()
xlApp.ScreenUpdating = False
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
Dim n As Integer
Dim arr As Variant
Dim rcount As Long
Dim ArrayLength As Integer
Dim l As String
Dim m As String
Dim r, i
With xlApp.ActiveSheet
l = xlApp.InputBox("请输入要分离的是哪一列", "确定参数对话框", "请输入", 2500, 3500)
If l <> "请输入" Then
Debug.Print "输入值为:" + l
End If
m = xlApp.InputBox("请输入分割的符号", "确定参数对话框", "请输入", 2500, 3500)
If m <> "请输入" Then
Debug.Print "输入值为:" + m
End If
rcount = xlApp.Cells(xlApp.Rows.Count, l).End(3).Row
For r = rcount To 1 Step -1
arr = Split(xlApp.Cells(r, l).Value, m)
ArrayLength = UBound(arr) - LBound(arr) + 1
For i = 1 To ArrayLength - 1
xlApp.Rows(r & ":" & r).Copy
xlApp.Rows(r + 1 & ":" & r + 1).Insert Shift:=xlDown
Next i
xlApp.Cells(r, l).Resize(ArrayLength, 1).Value = xlApp.WorksheetFunction.Transpose(arr)
Erase arr
Next r
xlApp.CutCopyMode = False
End With
xlApp.ScreenUpdating = True
End Sub