他のブックへのリンクを張る

Private Sub Workbook_Open()
      GetBooks
End Sub

'----- 転記された表へのポインタ
Public ProjectList As LinkBookClass
'         ・・・必要なだけ追加・・・
'
'これで PROJECT.xlsm を参照する ProjectList という LinkBookClass のインスタンスを生成しておき
Public Sub GetBooks()
      Application.ScreenUpdating = False
      Set ProjectList = Nothing: Set ProjectList = New LinkBookClass
      If Not ProjectList.Init("PROJECT","PROJECT.xlsm", "LIST") Then GoTo errTrap
'         ・・・上の２行必要なだけ追加・・・
errTrap:
      Application.ScreenUpdating = True
End Sub
'これで必要なセルの値を得る
Public Function GetProject(名前, 項目名)
      GetProject = ProjectList.GetValue(名前, 項目名)
End Function

'===== LinkBookClass のプロパティ
'----- 表が転記された targetSheet の名前
Public SheetName
'----- 転記された表の範囲
Public ListRange
'----- 項目名に対応したコラム番号
Private columnNum As Object
'===== 表の転送
'----- srcBookName, srcSheetName で示した元表を trgSheetName に転記して
'        必要なパラメータを作成する
Public Sub Init(trgSheetName, srcBookName, srcSheetName)
Dim description
      On Error GoTo errTrap
      'srcBookName が存在しなかった場合
      If Dir(ThisWorkbook.path & "" & srcBookName) = "" Then Err.Raise 999
      'srcBookName は存在する場合
      SheetName = Trim(trgSheetName)
      ArrangeSheet SheetName
      Set ListRange = TransferTable(srcBookName, srcSheetName, SheetName)
      description = getHeadings
      If Len(description) > 0 Then Err.Raise 998
      Exit Sub
errTrap:
      'ユーザー定義エラーは、513-65535を使用する（735,744,746,1004を除く）
      'https://excel-ubara.com/excelvba1/EXCELVBA434.html
      Select Case Err.number
            Case 998: description = """" & description & """ の項目名が重複しています。"
            Case 999: description = "(ブック)" & srcBookName & " が見当たりません。"
            Case 7: description = srcBookName & " に (シート)" & srcSheetName & " がありません。"
            Case Else: description = ""
      End Select
      ErrMessage Err, "LinkBookClass.Init", description
      Err.Clear
End Sub
'===== targetSheet 上の headingTable の参照
'----- 項目名とコラム番号の対照表作成
Private Function getHeadings()
Dim headingTable
      Set columnNum = CreateObject("Scripting.Dictionary")
      With Worksheets(SheetName)
            Set headingTable = .Range(.Range(HeadingIndex).Value)
      End With
      getHeadings = GetHeadingColumns(headingTable, columnNum)
End Function
'----- コラム番号１の内容と項目名から値を取得する
Public Function GetValue(key, headingName)
      GetValue = GetValueByNum(key, columnNum(headingName))
End Function
'----- コラム番号１の内容と項目番号から値を取得する
Public Function GetValueByNum(key, column)
      On Error Resume Next
      GetValueByNum = WorksheetFunction.VLookup(key, ListRange, column, False)
      If Err.number <> 0 Then GetValueByNum = ""
End Function

'----- 元表を掲載している sourceSheet へのパス
Private sourceSheetPath
'----- 転記する対象シート
Private sheetName
'----- 5行目に項目名の一覧を作成する
Private Const headingKeyRow = 5
'
'===== sheetName のシートがあれば全体をクリア、なければ新たに追加する
Public Sub ArrangeSheet(sheetName)
      If existSheet(sheetName) Then clearSheet (sheetName): Exit Sub
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = sheetName
End Sub
'----- sheetName のシートが存在すれば TRUE を返す
Private Function existSheet(sheetName)
Dim sh
      For Each sh In Worksheets
            If sh.Name = sheetName Then existSheet = True: Exit Function
      Next
End Function
'----- sheetName のシート全体をクリア
Private Sub clearSheet(sheetName)
      Worksheets(sheetName).Cells.Clear
End Sub
'
'===== 対象シートの sourceSheet と同じ位置にヘッダ付きの表をコピーする
'ヘッダを除く表の範囲を返す
Public Function TransferTable(srcBookName, srcSheetName, shName)
Dim sourceBookPath
      sheetName = Trim(shName)
      sourceBookPath = ThisWorkbook.path & "\[" & Trim(srcBookName) & "]"
      sourceSheetPath = "'" & sourceBookPath & Trim(srcSheetName) & "'!"
      getAddress KeyIndex
      getTable getAddress(HeadingIndex)
      Set TransferTable = getTable(getAddress(ListIndex))
End Function
'----- sourceSheet から表の範囲を取得してセルに記録する
'記録したアドレスを返す
Private Function getAddress(index)
Dim address
      With Worksheets(sheetName).Range(index)
            .formula = "= " & sourceSheetPath & index
            '条件設定のためのアドレス指定には、sheetName が必要
            watchFinished
            address = .Value
            address = Mid(address, InStr(1, address, "!") + 1, 99)
            getAddress = address
            .Value = sheetName & "!" & address
      End With
End Function
'----- address の位置にある表の値をコピーする
' 値が 0 であれば、空白に変更する
Private Function getTable(address) As Range
Dim v
      Set getTable = Worksheets(sheetName).Range(address)
      With getTable
            .Value = "=" & sourceSheetPath & address
            .Value = .Value
      End With
      watchFinished
      For Each v In getTable
            If v.Text = 0 Then v.Value = ""
      Next
End Function
'----- 計算が完了するまで待つ
Private Sub watchFinished()
      With Application
            Do While .CalculationState <> xlDone
                  If .CalculationState = xlPending Then .Calculate
                  DoEvents
            Loop
      End With
End Sub
'
'===== ヘッダ範囲と連想配列を受けて、ヘッダ文字とコラム番号の対照表を作成
'ヘッダ文字の重複があった場合、その文字を返す
Public Function GetHeadingColumns(headingTable, ByRef columnNum) As String
Dim headingKeyRange, headingText
      On Error GoTo errTrap
      fillBlankCells headingTable
      headingText = connectText(headingTable, columnNum)
      Set headingKeyRange = headingTable.Parent.Cells(headingKeyRow, headingTable.column). _
                                          Resize(1, headingTable.Columns.Count)
      headingKeyRange.Value = columnNum.keys
      With headingTable.Parent
            .Range(HeadingKeyIndex) = .Name & "!" & headingKeyRange.address
      End With
      GetHeadingColumns = ""
      Exit Function
errTrap:
      GetHeadingColumns = headingText
End Function
'----- 下層が空白でない空白セルを直前セルの値で埋める
Private Sub fillBlankCells(headingTable)
Dim row, clm, lastText
      For row = headingTable.Rows.Count - 1 To 1 Step -1
            For clm = 1 To headingTable.Columns.Count
                  With headingTable
                        If Len(.Cells(row, clm)) = 0 And Len(.Cells(row + 1, clm)) > 0 Then
                              .Cells(row, clm).Value = lastText
                        Else
                              lastText = .Cells(row, clm).Value
                        End If
                  End With
            Next
      Next
End Sub
'----- 全層の値を結合して columnNum に登録する
'値の重複があった場合は、その文字を返す
Private Function connectText(headingTable, ByRef columnNum) As String
Dim row, clm, headingText
      On Error GoTo errTrap
      With headingTable
            For clm = 1 To .Columns.Count
                  headingText = .Cells(1, clm).Value
                  For row = 2 To .Rows.Count
                       If Len(.Cells(row, clm)) > 0 Then headingText = headingText & "." & .Cells(row, clm)
                  Next
                  columnNum(headingText) = clm
            Next
      End With
      connectText = ""
      Exit Function
errTrap:
      connectText = headingText
End Function
'
'----- エラーメッセージの表示
Public Sub ErrMessage(error, Optional location = "", Optional description = "")
    If description = "" Then description = Err.description
    MsgBox description, vbOKOnly, "error:" & error.Number & "  " & location
End Sub