Implements IDTExtensibility2
Option 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

VB6调用Excel
http://club.
(出处: ExcelHome技术论坛)

我发现问题了，是窗体显示不出来，我可以输入，但是没有窗体，inputbox的窗体不显示，请问您知道是什么原因吗

去掉On Error Resume Next试试看