アドイン

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2734236/3c7f7cd5-11c4-470e-a34f-905c27b38699.png)


workbookシート
```
Private Sub workbook_open()
    newbar
    
    ThisWorkbook.IsAddin = False
    sttingkey
    ThisWorkbook.IsAddin = True
    ThisWorkbook.Saved = True
    
End Sub
```

モジュール
```
Sub newbar()
'CommandBars("Kin").Delete
Application.CommandBars.Add Name:="Kin", temporary:=True
Dim newcombar As CommandBar
Dim Mene As CommandBarControl
Dim button As CommandBarButton

Set newcombar = Application.CommandBars("Kin")
newcombar.Visible = True
newcombar.Position = msoBarLeft

'コンポネス１
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "転換"
.OnAction = "heightConvert"
.Style = msoButtonIconAndCaption
End With

'コンポネス２
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "共通ヘッダー"
.OnAction = "commonHead"
.Style = msoButtonIconAndCaption
End With

'コンポネス３
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "WHERE"
.OnAction = "test"
.Style = msoButtonIconAndCaption
End With

'コンポネス４
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "フォカス"
.OnAction = "doFocus"
.Style = msoButtonIconAndCaption
End With

'コンポネス６
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "セール結合"
.OnAction = "doMergeSail"
.Style = msoButtonIconAndCaption
End With

''コンポネス６
'With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
'.Width = 200
'.Caption = "セール結合"
'.OnAction = "doMergeSail"
'.style = msoButtonIconAndCaption
'End With
'
''コンポネス６
'With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
'.Width = 200
'.Caption = "セール結合"
'.OnAction = "doMergeSail"
'.style = msoButtonIconAndCaption
'End With

'コンポネス９
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "ファイル名変更"
.OnAction = "renFileName"
.Style = msoButtonIconAndCaption
End With


End Sub

Function converAddress(startRow As Long, startCol As Long, endRow As Long, endCol As Long)
    Dim startPoint As Integer
    Dim endPonint As Integer
    Dim addressStr As String
    Dim addressStrArr() As String
    Dim maxColumn As Long
    
    startPoint = ActiveCell.Column
    endPonint = ActiveCell.Height
    addressStr = Application.Selection.Address
    
    addressStrArr = Strings.Split(addressStr, ":")
    
'    チェック
    If UBound(addressStrArr) = 0 Then
        MsgBox "複数セルを選択してください。"
        converAddress = 0
        Exit Function
    End If
    
    startRow = Range(addressStrArr(0)).Row
    startCol = Range(addressStrArr(0)).Column
    endRow = Range(addressStrArr(1)).Row + 1
    endCol = Range(addressStrArr(1)).Column
    
End Function

Sub heightConvert()

    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hight As Integer
    Dim targetStartRow As Long
    Dim targetEndRow As Long
    Dim dataarr
    
    temp = converAddress(startRow, startCol, endRow, endCol)

    
    hight = endRow - startRow
    targetStartRow = endRow + 2
    targetEndRow = endRow + 2 + hight
    
    'チェック
    If endCol - startCol + 1 > 9000 Then
        MsgBox "選択列は100列超過。 "
        Exit Sub
    End If
    
    
    Dim i As Long
    Dim arr
    
    For i = startCol To endCol
'    列の単位のセルを取得
        arr = Range(Cells(startRow, i), Cells(endRow, i))
        
'        一列にマージ
        Range(Cells(targetStartRow, startCol), Cells(targetEndRow, startCol)).Value = arr
        
        targetStartRow = targetStartRow + hight
        targetEndRow = targetEndRow + hight
    Next
    
    MsgBox "完了"

End Sub

Sub doFocus()
    
    Dim sheetCount As Integer
    Dim i As Integer
    Dim hidenSheet As String
    hidenSheet = ""
    
    Dim hidenSheetFlg As Boolean
    hidenSheetFlg = False
    
    sheetCount = Sheets.Count

    For i = 1 To sheetCount
        If Sheets(i).Visible = 0 Then
            hidenSheet = hidenSheet & Sheets(i).Name & vbCrLf
            hidenSheetFlg = True
            GoTo continue
        End If
        
        Sheets(i).Select
        SelectRange (30)
continue:
    Next
    
    If 1 < sheetCount Then
        Sheets(2).Select
        Range("a1").Select
    End If

    If hidenSheetFlg Then
        MsgBox hidenSheet
    End If
End Sub

Function SelectRange(inpram As Integer) As String

    On Error GoTo MyError
        Range(Cells(inpram, 1), Cells(inpram, 1)).Select
        
        If inpram = 1 Then
            Exit Function
        End If
    
MyError:
        If inpram > 16 Then
            Call SelectRange(inpram - 5)
        Else
            Call SelectRange(inpram - 1)
        End If

End Function

Sub doMergeSail()

    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hight As Integer
    
    temp = converAddress(startRow, startCol, endRow, endCol)
    If temp = 0 Then
        Exit Sub
    End If
    
    hight = endRow - startRow
    
    'チェック
    If endCol - startCol + 1 > 9000 Then
        MsgBox "選択列は100列超過。 "
        Exit Sub
    End If
    
    Dim i As Long
    
    Dim mergeStart As Long
    Dim mergeEnd As Long
    mergeStart = startRow
    
    Application.DisplayAlerts = False
    
    For i = startCol To endCol
        
        If Cells(i, startCol) <> Cells(i + 1, startCol) Then
            mergeEnd = i
            
            Range(Cells(mergeStart, startCol), Cells(mergeStart, startCol)).Merge
            Range(Cells(mergeStart, startCol), Cells(mergeStart, startCol)).Select
            
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLeverl = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            With Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLeverl = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            With Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlTop
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLeverl = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = True
            End With
            
            mergeStart = i + 1
        
        End If
        
    Next
    
    MsgBox "完了"

End Sub

Function CONCATENATECSV(ran As Range) As String
    
    CONCATENATECSV = CONCATENATEAREAALL(ran, 1)

End Function

Function CONCATENATESPACE(ran As Range) As String
    
    CONCATENATESPACE = CONCATENATEAREAALL(ran, 2)

End Function


Function CONCATENATESTRBUFFERE(ran As Range) As String
    
    CONCATENATESTRBUFFERE = CONCATENATEAREAALL(ran, 0)

End Function


Function CONCATENATEAREAALL(ran As Range, options As Integer) As String
    
    Const QUOTATION_MARKS As String = """"
    Const SPACE As String = " "
    Const COMMA As String = ","
    
'    範囲選択する
    Dim startPoint As Integer
    Dim endPoint As Integer
    Dim addressStr As String
    Dim addressStrArr() As String
    Dim maxColumn As Long
    
    startPoint = ran.Column
    endPoint = ran.Height
    addressStr = ran.Address
    addressStrArr = Strings.Split(addressStr, ":")
    addressStr = Range(addressStrArr(0)).Column
    
'    チェック
    If UBound(addressStrArr) = 0 Then
        CONCATENATEAREAALL = QUOTATION_MARKS & ran.Value & QUOTATION_MARKS
        Exit Function
    
    End If
    
    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hight As Integer
    Dim targetStartRow As Long
    Dim targetEndRow As Long
    Dim dataarr
    Dim prefix As String
    Dim d As String
    
    startRow = Range(addressStrArr(0)).Row
    startCol = Range(addressStrArr(0)).Column
    endRow = Range(addressStrArr(1)).Row
    endCol = Range(addressStrArr(1)).Column
    
    Dim i As Long
    Dim ret As String
    
    If options = 0 Then
    
        prefix = ""
        suffix = ""
        
    ElseIf options = 1 Then
    
        prefix = QUOTATION_MARKS
        suffix = COMMA & QUOTATION_MARKS
        
    ElseIf options = 2 Then
    
        prefix = ""
        suffix = SPACE
        
    End If
    
    For J = startRow To endRow
        
        For i = startCol To endCol
            
            If i = startCol And J = startRow Then
                
                ret = ret & prefix & Cells(J, i) & prefix
            Else
                ret = ret & suffix & Cells(J, i) & prefix
            End If
        
        Next
    
    Next
    
    CONCATENATEAREAALL = ret
    
End Function

Function UPPERlLEFT(Str As String)

Dim ret As String

ret = Strings.UCase(Strings.Mid(Str, 1, 1)) & Strings.Mid(Str, 2, Len(Str))

UPPERlLEFT = ret

End Function

Function LOWER1LEFT(Str As String)

Dim ret As String

ret = Strings.LCase(Strings.Mid(Str, 1, 1)) & Strings.Mid(Str, 2, Len(Str))

LOWER1LEFT = ret

End Function

Function DATCRTSRT(Str As String)

    ret = """" & SelectUpcaps(Str) & "001" & """"
    
    DATCRTSRT = ret
    
End Function

Function SelectUpcaps(Str As String)

Dim lenth As Long, T As String, S As String, firstflg As Boolean

firstflg = True

J = Len(Str)
    For i = 1 To J
    
        S = Mid(Str, i, 1)
        
        If firstflg Then
            
            If S Like "[a-z]" Or S Like "A-Z" Then
            
                T = T & Strings.UCase(S)
            
            End If
        Else
            If Asc(S) > 64 And Asc(S) < 91 Then
                T = T & S
            
            End If
        
        End If
        
    Next i
    
    SelectUpcaps = T

End Function

Function CommandItems(ran As Range, Optional options = -1) As String
    
    Const QUOTATION_MARKS As String = """"
    Const SPACE As String = " "
    Const COMMA As String = ","
    
'    範囲選択する
    Dim startPoint As Integer
    Dim endPo9int As Integer
    Dim addressStr As String
    Dim addressStrArr() As String
    Dim maxColumn As Long
    
    startPoint = ran.Column
    endPoint = ran.Height
    addressStr = ran.Address
    addressStrArr = Strings.Split(addressStr, ":")
    addressStr = Range(addressStrArr(0)).Column
    
'    チェック
    If UBound(addressStrArr) = 0 Then
        CommandItems = QUOTATION_MARKS & ran.Value & QUOTATION_MARKS
        Exit Function
    
    End If
    
    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hight As lnteger
    Dim targetStartRow As Long
    Dim targetEndRow As Long
    Dim dataarr
    Dim prefix As String
    Dim d As String
    
    startRow = Range(addressStrArr(0)).Row
    startCol = Range(addressStrArr(0)).Column
    endRow = Range(addressStrArr(1)).Row
    endCol = Range(addressStrArr(1)).Column
    
    Dim i As Long
    Dim ret As String
    Dim io As Integer
    
    io = options
    
    ret = vbCrLf
    
    For J = startRow To endRow
        
        If J = endRow Then
            ret = ret & SetListItem(Cells(J, startCol), Cells(J, startCol + 1), io, True)
        Else
            ret = ret & SetListItem(Cells(J, startCol), Cells(J, startCol + 1), io, False)
        End If
        
    Next
    
    CommandItems = ret
    
End Function

Function SetListItem(nameJp As String, nameEn As String, oprantion As Integer, endflg As Boolean)

Dim retStr As String
Dim commaffix As String

commaffix = COMMA

If endflg Then
    commaffix = ""
End If

If oprantion = 1 Then
    retStr = Comment & nameJp & vbCrLf & nameEn + commaffix & vbCrLf
Else
    retStr = Comment & nameEn & vbCrLf & nameJp + commaffix & vbCrLf
End If

SetListItem = retStr

End Function

Sub renFileName()

    Dim startRow As Long
    Dim startCol As Long
    Dim endRow As Long
    Dim endCol As Long
    Dim hight As Integer
    Dim targetStartRow As Long
    Dim targetEndRow As Long
    Dim dataarr
    
    temp = converAddress(startRow, startCol, endRow, endCol)
    
    If temp = 0 Then
        Exit Sub
    End If
    
    hight = endRow - startRow
    targetStartRow = endRow + 2
    targetEndRow = endRow + 2 + hight
    
    'チェック
    If endCol - startCol + 1 > 9000 Then
        MsgBox "選択列は100列超過。 "
        Exit Sub
    End If
    
    Dim i As Long
    Dim oldNameArr
    Dim newNameArr
    Dim tempNameArr
    
    oldNameArr = Application.Transpose(Range(Cells(startRow, startCol), Cells(endRow, startCol)))
    tempNameArr = oldNameArr
    newNameArr = Application.Transpose(Range(Cells(startRow, endCol), Cells(endRow, endCol)))
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim oldPathName As String
    Dim newPathName As String
    Dim tempPathName As String
    
    Dim filePath As String
    filePath = oldNameArr(1)
    
    Dim InputBoxFlg As Boolean
    
    If filePath = "" Or newNameArr(1) <> "" Then
        filePath = InputBox("パスを入力してください。")
        
        InputBoxFlg = True
        
    Else
        
        InputBoxFlg = False
    End If
    
    If filePath = "" Then
        filePath = "1"
    
    End If
    
    If Mid(filePath, Len(filePath), 1) <> "\" Then
        filePath = filePath & "\"
    End If
    
    If InputBoxFlg Then
        
        oldPathName = filePath & oldNameArr(1)
        tempPathName = filePath & "temp_" & oldNameArr(1)
        
        tempNameArr(1) = tempName
        
        If fso.FileExists(oldPathName) And oldPathName <> newPathName Then
            
            Name oldPathName As tempPathName
            
        End If
        
    
    End If
    
    For i = 2 To UBound(oldNameArr) - 1
    
        oldPathName = filePath & oldNameArr(i)
        tempPathName = filePath & "temp_" & oldNameArr(i)
        
        tempNameArr(i) = tempPathName
        
        If fso.FileExists(oldPathName) And oldPathName <> newPathName Then
        
            Name oldPathName As tempPathName
        
        Else
            GoTo continue1
        End If
    
    
continue1:
    Next
    
    If InputBoxFlg Then
        
        newPathName = filePath & newNameArr(1)
        tempPathName = tempNameArr(i)
        
        If fso.FileExists(tempPathName) Then
        
        End If
    
    End If
    
    For i = 2 To UBound(oldNameArr) - 1
    
        newPathName = filePath & newNameArr(i)
        tempPathName = tempNameArr(i)
        
        If fso.FileExists(tempPathName) Then
            Name tempPathName As newPathName
        Else
            GoTo continue2
        End If
    
continue2:
    Next
    
    MsgBox "完了"

End Sub


Sub sttingkey()
    Application.MacroOptions Macro:="heightConvert", HasshortcutKey:=True, ShortcutKey:="j"
    Application.MacroOptions Macro:="doFocus", HasshortcutKey:=True, ShortcutKey:="m"
End Sub

```

```
1、打开Microsoft Excel 。
2、点击左上角文件，然后点开箭头所指的“选项”。
3、弹出excel选项的窗口后，下拉选择箭头所指的“加载项”。
4、在下面的“管理”中选择禁用项目，然后鼠标左击旁边的“转到”。
5、在弹出的“禁用”窗口中查看是否有被禁用的项目，如果有，选择启用。
```

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2734236/8fc3006a-5b28-7f12-fc29-353b49d0ba33.png)
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2734236/307d4f99-d9c4-2a37-1e9f-30f1be7df7ab.png)
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2734236/9f835abc-4425-f5da-ba52-62ff12ada786.png)