VBA-加载项工具开发

之前写了一个简单的加载项菜单博客，应用于实际工作中，写了一个工具用于分配任务。

'create menus when this workbook opened
Public Sub createMenus()
    deleteMenus
    Dim cbMyTool As CommandBar
    Dim cbbMyButton As CommandBarButton

    'Make the toolbar
    Set cbMyTool = CommandBars.Add

    'Add a button to the toolbar.
    Set cbbMyButton = cbMyTool.Controls.Add(msoControlButton)
    With cbbMyButton
        .Caption = "taskAdd"
        .Style = msoButtonIconAndCaption
        .OnAction = "onClickBtn"
        .FaceId = 222
        .TooltipText = "button.TooltipText"
    End With

'The toolbar gets a name and is put on the screen.
   With cbMyTool
     .Name = "NPA Tools"
     .Visible = True
  End With
  
BeforeExit:
    Set cbMyTool = Nothing
    Set cbbMyButton = Nothing

    Exit Sub
ErrorHandle:
    Debug.Print Err.Description & " CreateMenus"
    Resume BeforeExit
End Sub

'delete menus we created before this workbook close.
Public Sub deleteMenus()
    'Removes the toolbar "Shortcuts".
    'If it doesn't exist we get an error,
    'and that is why we use On Error Resume Next.
    On Error Resume Next
    CommandBars("NPA Tools").Delete
End Sub


Public Sub onClickBtn()
    Dim rowCells, rowCell As Variant
    rowCells = readExcelRowCellsByPath
        Dim i As Integer
    For i = 2 To UBound(rowCells)
    copy_rows
    Next i
    

    For i = 0 To UBound(rowCells)
    
    Dim columnValues As Variant
    columnValues = Split(rowCells(i), ",")
    Cells(3 + 4 * i, 2).Value = columnValues(1)
    Cells(3 + 4 * i, 3).Value = columnValues(2)
    Cells(3 + 4 * i, 4).Value = columnValues(3)
    'Debug.Print columnValues(2)
    Next i

End Sub

Sub copy_rows()
' copy_rows Macro
    Range("B7:G10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B11").Select
    Selection.Insert Shift:=xlDown
    Range("B15").Select
End Sub

Option Explicit
'read excel by file_path
Public Function readExcelRowCellsByPath() As Variant
    Dim dataExcel, Workbook, sheet, totalColumn, redminePath
    Dim totalRow

    Set dataExcel = CreateObject("Excel.Application")
    redminePath = getFilePathByPicker
    Set Workbook = dataExcel.Workbooks.Open(redminePath)
    Set sheet = Workbook.Worksheets(1)
    
    totalRow = sheet.UsedRange.Rows.Count
    totalColumn = sheet.UsedRange.Columns.Count
    
    Dim arr, columnIndexs, columnValues As Variant
    Dim rowCells() As String
    ReDim rowCells(0 To totalRow - 2)

    arr = columnNames("#,題名,ストーリーポイント")
    Dim i, j As Long
    If totalRow > 1 And totalColumn > 1 Then
        For i = 2 To totalRow
           Dim oneRow As String
           For j = 1 To totalColumn
                If Not IsError(Application.Match(sheet.Cells(1, j).Value, arr, 0)) Then
                    oneRow = oneRow + "," + sheet.Cells(i, j).Value
                End If
            Next j
            rowCells(i - 2) = oneRow
            oneRow = ""
        Next i
    End If
    readExcelRowCellsByPath = rowCells
    Workbook.Close
End Function

'#,題名,予定工数
Public Function columnNames(ByVal targetStr As String) As Variant
columnNames = Split(targetStr, ",")
End Function

Public Function getFilePathByPicker() As String
Dim FileDialogObject
Set FileDialogObject = Application.FileDialog(msoFileDialogFilePicker)
With FileDialogObject
    .Title = "task issue from redmine"
    .InitialFileName = "C:\Users\Administrator\Downloads\issues.xlsx"
    .AllowMultiSelect = True
End With
FileDialogObject.Show
If FileDialogObject.SelectedItems.Count > 0 Then
getFilePathByPicker = FileDialogObject.SelectedItems(1)
End If
End Function