'=========================================================================================
Option Explicit
Const 元ブック As String = "元ブック.xls"
Const DBシート名 As String = "検索Data"
Const 別ブック As String = "別ブック.xls"
Const 集計シート名 As String = "編集後リスト"
Const 変換テーブル As String = "置き換えData"
Dim DB範囲, ソース範囲, インデックス
Dim パス, 右端列, 列, 検索値, セル範囲, 検索範囲, 答列, 検索型, 製品名
'-----------------------------------------------------------------------------------------
Sub 製品構成別製品名別に集計する()
    検索Dataからピボットテーブルを作成してコピーする
    別ブックを開いて編集後リストに貼り付ける
    型番を製品名に変換して不要な1行目を削除する
    Workbooks(元ブック).Close savechanges:=False  '上書き保存しないで閉じる
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 検索Dataからピボットテーブルを作成してコピーする()
    With Worksheets(DBシート名)
        .Activate
        DB範囲 = "A1:C" & .Range("A" & Rows.Count).End(xlUp).Row
        ソース範囲 = DBシート名 & "!" & DB範囲
        ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        ソース範囲).CreatePivotTable TableDestination:=""
    End With
    インデックス = 1                            'ピボットテーブルのインデックス番号
    With ActiveSheet                            'ピボットテーブルが作成された新しいシート
        .Range("A3").Select
        With .PivotTables(インデックス)
            .PivotFields("製品構成").Orientation = xlRowField
            .PivotFields("型番").Orientation = xlColumnField
            .PivotFields("使用点数").Orientation = xlDataField
            .TableRange1.Copy                   'データフィールドをコピー
        End With
    End With
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 別ブックを開いて編集後リストに貼り付ける()
    パス = ThisWorkbook.Path
    Workbooks.Open Filename:=(パス & "\" & 別ブック) '別ブックを開く
    With Workbooks(別ブック).Worksheets(集計シート名)
        .Activate
        .Range("A1").PasteSpecial Paste:=xlPasteValues 'データフィールドを貼り付け
    End With
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 型番を製品名に変換して不要な1行目を削除する()
    With Workbooks(別ブック).Worksheets(集計シート名)
        右端列 = .Cells(2, Columns.Count).End(xlToLeft).Column '2行目の右端列を取得
        For 列 = 2 To 右端列 - 1
            検索値 = .Cells(2, 列).Value        '型番
            With Workbooks(元ブック).Worksheets(変換テーブル)
                セル範囲 = "A1:B" & .Range("A" & Rows.Count).End(xlUp).Row
                Set 検索範囲 = .Range(セル範囲) '[置き換えData]の範囲
            End With
            答列 = 2                            '答の列番号
            検索型 = False                      '完全一致検索
            製品名 = Application.WorksheetFunction.VLookup(検索値, 検索範囲, 答列, 検索型)
            .Cells(2, 列).Value = 製品名        '型番を製品名に置換する
        Next
        .Rows("1:1").Delete Shift:=xlUp         'データフィールドの1行目を削除する
    End With
End Sub
'=========================================================================================