Excel add-in 备忘

两项机能：

1、自动添加工具栏按钮，文档关闭时，自动删除所添加的工具栏按钮
2、点击按钮图标，执行模块(Module)中的宏机能

注：在取得工具栏对象时，如果指定名称的工具栏不存在，会报错。下面代码的处理是对工具栏集合进行遍历，判断是否存在，当然，也可以直接使用异常处理(on error goto)来进行判断。

代码1(ThisWorkBook)：

Option Explicit
Const toolbarCaption As String = "MyToolbar"
Const onActionString As String = "autoAdjust"

Private Sub Workbook_Open()
   Dim toolbar As CommandBar
 
   Set toolbar = getCommandBar(toolbarCaption)
   If toolbar Is Nothing Then
       Set toolbar = Application.CommandBars.Add(Name:=toolbarCaption)
       toolbar.Visible = True
   End If
 
   With toolbar.Controls.Add(Type:=msoControlButton, Before:=1)
       .Caption = "Auto Adjust"
       .TooltipText = "Run Auto Adjust"
       .OnAction = onActionString
       ThisWorkbook.Worksheets(1).Shapes(1).Copy
       .PasteFace
   End With
 
   Set toolbar = Nothing
 
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Dim toolbar As CommandBar
   Dim i As Integer
 
   Set toolbar = getCommandBar(toolbarCaption)
   If toolbar Is Nothing Then
       Exit Sub
   End If
 
   For i = 1 To toolbar.Controls.Count
       With toolbar.Controls(i)
           If .OnAction = "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'!" & onActionString Then
               .Delete
               Exit For
           End If
       End With
   Next i
 
   If toolbar.Controls.Count = 0 Then
       toolbar.Delete
       Set toolbar = Nothing
   End If
End Sub

Private Function getCommandBar(barCaption As String)
   Dim i As Integer
 
   For i = Application.CommandBars.Count To 1 Step -1
       If Application.CommandBars(i).Name = barCaption Then
           Set getCommandBar = Application.CommandBars(i)
           Exit Function
       End If
   Next i
 
   Set getCommandBar = Nothing
End Function


代码2(Module)：

Option Explicit

Sub autoAdjust()
   Dim formulaString As String
   Dim i As Integer
   Dim sheet As Worksheet
 
   Set sheet = ActiveSheet
 
   'addjust column
   sheet.Columns("E:Z").ColumnWidth = 8
   sheet.Columns("G:G").Delete Shift:=xlToLeft
   sheet.Columns("H:H").Delete Shift:=xlToLeft
   sheet.Columns("I:J").Delete Shift:=xlToLeft
   sheet.Columns("J:J").Delete Shift:=xlToLeft
 
   ' unmerge
   Dim mergeCells, cell As Range
   Dim formula As Variant
   Dim iRow, iCol As Integer
 
   For iRow = 3 To 100
       For iCol = 1 To 15
           Set cell = sheet.Cells(iRow, iCol)
           If cell.mergeCells Then
               Set mergeCells = cell.MergeArea
               cell.UnMerge
               formula = cell.formula
               mergeCells.Cells.formula = formula
           End If
       Next iCol
   Next iRow
 
   'split size
   'size formula format: =length * width * height
   Dim lst() As String
   For i = 3 To 100
       formulaString = sheet.Cells.Item(i, "I").formula
       If Len(formulaString) > 1 Then
           lst = Split(Mid(formulaString, 2), "*")
           If UBound(lst) <> 2 Then
               With sheet.Range(sheet.Cells.Item(i, "I"), sheet.Cells.Item(i, "L"))
                   .formula = formulaString
                   .Interior.ColorIndex = 3
                   .Interior.Pattern = xlSolid
               End With
           Else
               sheet.Cells.Item(i, "J") = lst(0)    'length
               sheet.Cells.Item(i, "K") = lst(1)    'width
               sheet.Cells.Item(i, "L") = lst(2)    'height
           End If
       End If
   Next i
 
   sheet.Columns("I:I").Delete Shift:=xlToLeft
   sheet.Columns("A:B").Insert Shift:=xlToRight
 
   sheet.Range("A3:A100") = Split(ActiveWorkbook.Name, ".")(0)
   sheet.Range("B3") = 1
   Range("B4").FormulaR1C1 = "=R[-1]C + 1"
   Range("B4").AutoFill Destination:=Range("B4:B96"), Type:=xlFillDefault
   Range("B3").Select

End Sub

(完)