【知らなくても使える】Excel標準機能にない差し込み出力ができるアドイン（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const All_SHEET = "全シート"        '１．全シートを選択する時のシート名
'---------------------------------------

Private RbRibbon As IRibbonUI               'リボン
Private TableItems As Variant               'テーブル名（配列）
Private SelectedTableNm As String           '選択したテーブル名
Private ColumnItems As Variant              '項目名（配列）
Private SelectedColumnNm As String          '選択した項目
Private SheetItems As Variant               'シート名（配列）
Private SelectedSheetNm As String           '選択したシート名
Private MatchRange As Range                 '検索して一致した項目（range）
Private DicMatchRange As Object             '一致した項目を保存するオブジェクト
Private PrintSheets As Variant              '印刷する際のシート

'---------（メッセージ）-----------------------
Private Const Msg1 = "PDFファイルで出力が完了しました。"
Private Const Msg2 = "PDFファイルが既に開かれています。" & vbLf & "ファイルを閉じてから再度実行して下さい。"
'----------------------------------------------

'===================================
'リボンの初期処理
'===================================
Sub onLoad_dataInset(ribbon As IRibbonUI)

    'リボンの表示を更新できるようにするためにリボンをセットする
    Set RbRibbon = ribbon
    RbRibbon.Invalidate
    
    Call getDataTables      'テーブルデータを取得
    Call getColumns         '項目データを取得
    Call getSheets          'シート名を取得
    
    Set DicMatchRange = CreateObject("Scripting.Dictionary")
    
End Sub

'===================================
'テーブルを取得をクリックした際の処理
'===================================
Public Sub btn_getDataTable_onClick(control As IRibbonControl)
    
    SelectedTableNm = ""
    
    Call getDataTables      'テーブルデータを取得
    Call getColumns         '項目データを取得
    Call getSheets          'シート名を取得

    RbRibbon.InvalidateControl "drdn_dataTable"
    RbRibbon.InvalidateControl "DMn_insertItem"
    RbRibbon.InvalidateControl "drdn_sheetName"
    RbRibbon.InvalidateControl "btn_influence"
    RbRibbon.InvalidateControl "btn_return"
    RbRibbon.InvalidateControl "Mn_print"
    
End Sub


'=== テーブル名（ドロップダウンリスト）===================================== start ===
Public Sub drdn_dataTable_getItemCount(control As IRibbonControl, ByRef returnedVal)

    If UBound(TableItems) <> -1 Then
        returnedVal = UBound(TableItems) + 1
    End If

End Sub

Public Sub drdn_dataTable_getItemID(control As IRibbonControl, index As Integer, ByRef returnedVal)
    
    returnedVal = "tableItem" & index
  
End Sub

Public Sub drdn_dataTable_getItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)

    returnedVal = TableItems(index)
    
End Sub

Public Sub drdn_dataTable_getSelectedItemID(control As IRibbonControl, ByRef returnedVal)
  
    If UBound(TableItems) <> -1 Then
        SelectedTableNm = TableItems(0)
    End If
    returnedVal = "tableItem0"
  
End Sub

Public Sub drdn_dataTable_getEnabled(control As IRibbonControl, ByRef returnedVal)

    If UBound(TableItems) = -1 Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

' == テーブル名を選択した際の処理 ====
Public Sub drdn_dataTable_onClick(control As IRibbonControl, id As String, index As Integer)

    SelectedTableNm = TableItems(index)
    
    Call getColumns         '項目データを取得
    Call getSheets          'シート名を取得
    
    PrintSheets = Array()
    ReDim Preserve PrintSheets(0)
    
    RbRibbon.InvalidateControl "DMn_insertItem"
    RbRibbon.InvalidateControl "drdn_sheetName"
    RbRibbon.InvalidateControl "btn_influence"
    RbRibbon.InvalidateControl "btn_return"
    RbRibbon.InvalidateControl "Mn_print"
    
End Sub


'=== 項目を挿入（ダイナミックメニュー）===================================== start ===
Public Sub DMn_getContent(control As IRibbonControl, ByRef returnedVal)

    returnedVal = getContents()

End Sub

Public Sub DMn_getEnabled(control As IRibbonControl, ByRef returnedVal)
    
    If UBound(ColumnItems) = -1 Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

' == 項目を選択した際の処理 ====
Public Sub btnItem_onAction(control As IRibbonControl)

    SelectedColumnNm = ColumnItems(Split(control.id, "Item")(1))
    
    Dim c As Range
    Set c = Selection

    c.Value = "≪#" & SelectedColumnNm & "≫"

End Sub


'=== シート名（ドロップダウンリスト）======================================= start ===
Public Sub drdn_sheetName_getEnabled(control As IRibbonControl, ByRef returnedVal)
    
    If UBound(SheetItems) = -1 Or SheetItems(0) = "" Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

Public Sub drdn_sheetName_getItemCount(control As IRibbonControl, ByRef returnedVal)

    If UBound(SheetItems) <> -1 Then
        returnedVal = UBound(SheetItems) + 1
    End If
    
End Sub

Public Sub drdn_sheetName_getItemID(control As IRibbonControl, index As Integer, ByRef returnedVal)
    returnedVal = "sheetItem" & index
    
End Sub

Public Sub drdn_sheetName_getItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)
    returnedVal = SheetItems(index)
    
End Sub

Public Sub drdn_sheetName_getSelectedItemID(control As IRibbonControl, ByRef returnedVal)
    
    If UBound(SheetItems) <> -1 Then
        SelectedSheetNm = SheetItems(0)
    End If
    
    returnedVal = "sheetItem0"
    
End Sub

' == 対象シートを選択した際の処理 ====
Public Sub drdn_sheetName_onClick(control As IRibbonControl, id As String, index As Integer)
    
    SelectedSheetNm = SheetItems(index)
    
End Sub


'=== 反映ボタン ============================================================ start ===
Public Sub btn_influence_getEnabled(control As IRibbonControl, ByRef returnedVal)

    If UBound(SheetItems) = -1 Or SheetItems(0) = "" Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

' == 反映ボタンをクリックした際の処理 ====
Public Sub btn_influence_onClick(control As IRibbonControl)
        
    Call influenceItem      '項目をテーブルデータで反映
    
End Sub


'=== 戻すボタン ============================================================ start ===
Public Sub btn_return_getEnabled(control As IRibbonControl, ByRef returnedVal)

    If UBound(SheetItems) = -1 Or SheetItems(0) = "" Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

' == 戻すボタンをクリックした際の処理 ====
Public Sub btn_return_onClick(control As IRibbonControl)
    
    Dim tmpSheet As Worksheet
        
    '対象ファイルの全シートを1つずつループして処理する
    For Each tmpSheet In ActiveWorkbook.Worksheets
        
        If SelectedSheetNm = All_SHEET Or tmpSheet.Name = SelectedSheetNm Then
        
            Dim tgtKeys As Variant
            Dim tgtSheetRange As Variant
            Dim tgtItemValue As Variant
            
            For Each tgtKeys In DicMatchRange.Keys
                    
                tgtSheetRange = Split(tgtKeys, "/")
                
                '項目名をテーブルデータで置換する
                tmpSheet.Range(tgtSheetRange(1)).Replace What:=tgtSheetRange(3), Replacement:=tgtSheetRange(2), _
                    LookAt:=xlPart, MatchCase:=True, matchbyte:=True
            
            Next
        End If
    Next
    
End Sub


'=== 差し込み出力ボタン ==================================================== start ===
Public Sub Mn_print_getEnabled(control As IRibbonControl, ByRef returnedVal)

    If UBound(SheetItems) = -1 Or SheetItems(0) = "" Then
        returnedVal = False
    Else
        returnedVal = True
    End If
    
End Sub

' == 「選択した対象シートを出力」をクリックした際の処理 ====
Public Sub btn_partPrint_onAction(control As IRibbonControl)

    Call influenceItem              '項目をテーブルデータで反映
    Call savePdf(PrintSheets)       'PDF出力
    
End Sub


'-----------------------------------
'テーブルデータを取得する処理
'-----------------------------------
Private Sub getDataTables()
    
    Dim ws As Variant, tempT As Variant, i As Long
    
    TableItems = Array()
    
    ReDim Preserve TableItems(i)
    TableItems(i) = ""
    i = i + 1
    
    'すべてのシートをループ
    For Each ws In Worksheets
    
        'シート内で、すべてのテーブルをループ
        For Each tempT In ws.ListObjects
        
            ReDim Preserve TableItems(i)
            
            'テーブル名を取得
            TableItems(i) = tempT.Name
            i = i + 1
            
        Next
    Next
    
End Sub

'-----------------------------------
'表示させる項目を取得する処理
'-----------------------------------
Private Function getContents() As String

    Dim domD As Object
    Dim elmMenu As Object
    Dim elmButton As Object
    Dim i As Long
     
    Set domD = CreateObject("Msxml2.DOMDocument")
    Set elmMenu = domD.createElement("menu")
    elmMenu.setAttribute "xmlns", "http://schemas.microsoft.com/office/2006/01/customui"
    elmMenu.setAttribute "itemSize", "normal"
    
    For i = 0 To UBound(ColumnItems)
        
        '表示させる項目をボタン形式で設定する
        Set elmButton = domD.createElement("button")
        With elmButton
            .setAttribute "id", "columnItem" & i
            .setAttribute "label", ColumnItems(i)
            .setAttribute "imageMso", "InkingStart"
            .setAttribute "onAction", "btnItem_onAction"
        End With
        elmMenu.appendChild elmButton
        Set elmButton = Nothing
    
    Next
        
    '作成したxmlを反映させる
    domD.appendChild elmMenu
    getContents = domD.XML
  
End Function

'-----------------------------------
'テーブル内の項目を取得する処理
'-----------------------------------
Private Sub getColumns()
    
    Dim i As Long
    Dim col As ListColumn
    Dim wlo As Variant
    Dim ws As Worksheet
    Dim tempTable As Variant
    
    ColumnItems = Array()

    If SelectedTableNm <> "" Then
    
        'すべてのシートをループ
        For Each ws In ActiveWorkbook.Sheets
        
            'シート内で、全てのテーブルをループ
            For Each tempTable In ws.ListObjects
                
                If tempTable.Name = SelectedTableNm Then
                    
                    For Each col In ws.ListObjects(SelectedTableNm).ListColumns
                    
                        ReDim Preserve ColumnItems(i)
                        
                        '項目名を取得
                        ColumnItems(i) = col.Name
                        i = i + 1
                    Next
                    
                End If
            Next
        Next
        
    End If
    
End Sub

'-----------------------------------
'シート名の値を取得する処理
'-----------------------------------
Private Sub getSheets()
    
    Dim ws As Variant, tempT As Variant, i As Long
    
    SheetItems = Array()
    
    If SelectedTableNm <> "" Then
        
        '要素数を宣言
        ReDim Preserve SheetItems(i)
        SheetItems(i) = All_SHEET
        i = i + 1
        
        'すべてのシートをループ
        For Each ws In Worksheets
            
            ReDim Preserve SheetItems(i)
            
            'シート名を取得
            SheetItems(i) = ws.Name
            
            i = i + 1
            
        Next
    Else
    
        ReDim Preserve SheetItems(0)
        SheetItems(0) = ""
         
    End If
    
End Sub

'--------------------------------------------
'項目を対応したテーブルデータに反映する処理
'--------------------------------------------
Private Sub influenceItem()

    Dim tmpSheet As Worksheet
    Dim tgtRowNum As Long: tgtRowNum = 1
    Dim tgtSheetNum As Long
    Dim i As Long
    Dim isExist As Boolean
    Dim searchSheets() As String
    
    '対象ファイルの全シートを1つずつループして処理する
    For Each tmpSheet In ActiveWorkbook.Worksheets
        
        If SelectedSheetNm = All_SHEET Or tmpSheet.Name = SelectedSheetNm Then
            
            Dim aList As ListObject
            Set aList = Range(SelectedTableNm).ListObject

            Dim col As ListColumn
            Dim fAddress As String
            
            '列の種類だけ実行する
            For Each col In aList.ListColumns
              
                '検索して一致した範囲を保存しておく。
                Set MatchRange = tmpSheet.Cells.Find(What:="≪#" & col.Name & "≫", _
                                                    LookAt:=xlPart, MatchCase:=True, matchbyte:=True)
                
                If Not MatchRange Is Nothing Then
    
                    '列のデータ数分だけ実行する
                    For i = tgtRowNum To aList.ListColumns(col.Name).DataBodyRange.Count

                        fAddress = MatchRange.Address
                        
                        Do
                            Set MatchRange = tmpSheet.Cells.FindNext(MatchRange)
                            If MatchRange Is Nothing Then Exit Do
                            
                            '辞書オブジェクトに既に登録されている場合は、登録処理をしない
                            If DicMatchRange.exists(tmpSheet.Name & "/" & MatchRange.Address & "/" & "≪#" & col.Name & "≫" & "/" & aList.ListColumns(col.Name).DataBodyRange(i)) = False Then
                                DicMatchRange.Add tmpSheet.Name & "/" & MatchRange.Address & "/" & "≪#" & col.Name & "≫" & "/" & aList.ListColumns(col.Name).DataBodyRange(i), ""
                            End If
                            
                        Loop Until MatchRange.Address = fAddress
                        
                        '項目名を該当する値に置換する
                        tmpSheet.Cells.Replace What:="≪#" & col.Name & "≫", Replacement:=aList.ListColumns(col.Name).DataBodyRange(i), _
                                                LookAt:=xlPart, MatchCase:=True, matchbyte:=True
                        
                        isExist = True
                        Exit For
                        
                    Next
                    
                    searchSheets = Filter(PrintSheets, tmpSheet.Name)
 
                    If UBound(searchSheets) = -1 Then
                    
                        ReDim Preserve PrintSheets(tgtSheetNum)
                        PrintSheets(tgtSheetNum) = tmpSheet.Name
                        tgtSheetNum = tgtSheetNum + 1
                        
                    End If
                End If
            Next
            
            If isExist Then tgtRowNum = tgtRowNum + 1
        End If
                
    Next
    
End Sub


'-------------------------
'PDFファイルの保存処理
'　引数：sheetNmArray（対象のシート名が入った配列）
'-------------------------
Sub savePdf(sheetNmArray As Variant)
    
    On Error GoTo Err1

    Dim selSheetNm As String
    selSheetNm = ActiveSheet.Name
    
    Dim objFileSys As Object
    Dim noExtensionFileName As String
    Dim fileName As Variant
    Dim sheetNm As Variant
    
    'ファイルシステムを扱うオブジェクトを作成
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
     
    '拡張子無しのファイル名を取得
    noExtensionFileName = objFileSys.GetBaseName(ActiveWorkbook.FullName)

    'PDFファイルの保存先とファイル名称を指定する
    fileName = Application.GetSaveAsFilename(InitialFileName:=noExtensionFileName, FileFilter:="PDF,*.pdf")
    If fileName <> False Then
    
        Worksheets(sheetNmArray).Select
        
        'PDF出力処理
        ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            fileName:=fileName
            
        MsgBox Msg1
        
    End If
    
    Worksheets(selSheetNm).Select
    Exit Sub
    
Err1:
    If Err.Number <> 0 Then
       MsgBox Msg2
    End If
End Sub