VBA 他のBook参照覚書

他のXlBookを開く、マスタとするエクセルシートなどを参照するケース。

前提。
マスターとしてのエクセルファイルがある -- 経産省の鉱工業指数のデータを参考にした。
別にデータのエクセルファイルがある。（参考なし）
経産省のサイトから「b2020_weight1j.xlsx」をダウンロードし、このエクセルシートの「2020_C01 (J1)」シートを対象とした。
このシートのデータ行の内容をClassとして取得、Dictionaryでもよいが、メソッドを追加する可能性も考えてCollectionとしてシートのデータを取得。
このシートは階層を列で表している。Level0 からLevel5まであるが、Level5内で先頭文字空白による階層が追加されておりLevel6まであることになる。　参考
classの作成時には、それぞれのLevelと親コードを登録して階層を登録。また子供があるときは子供の数を参考までに登録。
子供の有無は数でチェックする。
マスターとして、集計する際のオプション項目列などを追加しておくなどすると有用。
経産省のデータは階層が変わっていたので、取得する練習になった。
これは、XMLで保存すると良い感じになるかも。

ローカルに経産局のサイトを見てみると独自の基準ウェイトが用意されている。
「h27y_bizcategory_item.xlsx」（中国経産局）
こちらはシートが業種ウェイトと品目ウエイトと階層で分かれている。
業種ウェイトが出力する集計項目となっておりわかりやすいので、こちらをモデルとする。

階層別となっているが、品目ウェイトのシートに業種ウェイトのIDがあるわけではなく、業種ウェイトの方に、対象とする品目ウェイトの対象範囲が示されている。
なので、データを取得する際に、経産省のケース同様に親IDを取得して登録するようにする。
業種ウェイトは親マスタといえるが、よくみるとこの中にも先頭スペースによる下位階層がある。
おそらく、経産省同様に階層があって、集計項目以外の中間の階層は省いているということ。
Classとしては、業種ウェイトにも親IDを登録する機能が必要。

指定されたファイルパス、シート番号のエクセルの表を読み、Class & Collectionに保持する。
必要はないが、読み込んだマスター、データの内容もシートに展開する。

本来はデータの内容にマスタにあるウェイトを使って処理した結果を出力するのだろうけど、そこは割愛。
当然ながら、データの品目IDが、マスタとした品目ウェイトのIDと同じでないと何も成立しない。

最初に、ファイルパスなどの変数やクラス（コレクション）のインスタンスを管理するルートクラスを用意する。
[clsManage]

Option Explicit

Private varSavePath As String                   '最終的に保存するファイル名
Private varSaveFile As String

Private varItemPath As String                   '経産省の品目
Private varItemFile As String
Private varItemSheet As String
'
Private varReMstPath As String                  '再掲項目
Private varReMstFile As String
Private varReMstSheet As String
'
Private varIndMstPath As String                 '業種ウェイト
Private varIndMstFile As String
Private varIndMstSheet As String
'
Private varCItemPath As String                  '品目ウェイト
Private varCItemFile As String
Private varCItemSheet As String
'
Private varIIPDataPath As String                'データ
Private varIIPDataFile As String
Private varIIPDataSheet As String
'
Private varProductPath As String                '生産
Private varProductFile As String
Private varProductSheet As String
'
Private varShipPath As String                   '出荷
Private varShipFile As String
Private varShipSheet As String
'
Private varInventoryPath As String              '在庫
Private varInventoryFile As String
Private varInventorySheet As String
'
Private varRatePath As String                   '在庫率
Private varRateFile As String
Private varRateSheet As String

'   ルートで管理するコレクション
Private varColItems As colItems                 '経産省の品目
Private varColReMsts As colReMsts               '再掲項目
Private varColIndMsts As colIndMsts             '業種ウェイト
Private varColCItems As colCItems               '品目ウェイト
Private varColIIPDatas As colIIPDatas           'データ

Private Sub Class_Initialize()
    varSavePath = ""
    varSaveFile = ""
    varItemPath = ""
    varItemFile = ""
    varItemSheet = ""
    varReMstPath = ""
    varReMstFile = ""
    varReMstSheet = ""
    varIndMstPath = ""
    varIndMstFile = ""
    varIndMstSheet = ""
    varCItemPath = ""
    varCItemFile = ""
    varCItemSheet = ""
    varIIPDataPath = ""
    varIIPDataFile = ""
    varIIPDataSheet = ""
    varProductPath = ""
    varProductFile = ""
    varProductSheet = ""
    varShipPath = ""
    varShipFile = ""
    varShipSheet = ""
    varInventoryPath = ""
    varInventoryFile = ""
    varInventorySheet = ""
    varRatePath = ""
    varRateFile = ""
    varRateSheet = ""
    '
    Set varColItems = Nothing
    Set varColReMsts = Nothing
    Set varColIndMsts = Nothing
    Set varColCItems = Nothing
    Set varColIIPDatas = Nothing
End Sub


Public Property Get SavePath() As String
    SavePath = varSavePath
End Property

Public Property Let SavePath(ByVal vNewValue As String)
    varSavePath = vNewValue
End Property

Public Property Get SaveFile() As String
    SaveFile = varSaveFile
End Property

Public Property Let SaveFile(ByVal vNewValue As String)
    varSaveFile = vNewValue
End Property

Public Property Get ItemPath() As String
    ItemPath = varItemPath
End Property

Public Property Let ItemPath(ByVal vNewValue As String)
    varItemPath = vNewValue
End Property

Public Property Get ItemFile() As String
    ItemFile = varItemFile
End Property

Public Property Let ItemFile(ByVal vNewValue As String)
    varItemFile = vNewValue
End Property

Public Property Get ItemSheet() As String
    ItemSheet = varItemSheet
End Property

Public Property Let ItemSheet(ByVal vNewValue As String)
    varItemSheet = vNewValue
End Property

Public Property Get ReMstPath() As String
    ReMstPath = varReMstPath
End Property

Public Property Let ReMstPath(ByVal vNewValue As String)
    varReMstPath = vNewValue
End Property

Public Property Get ReMstFile() As String
    ReMstFile = varReMstFile
End Property

Public Property Let ReMstFile(ByVal vNewValue As String)
    varReMstFile = vNewValue
End Property

Public Property Get ReMstSheet() As String
    ReMstSheet = varReMstSheet
End Property

Public Property Let ReMstSheet(ByVal vNewValue As String)
    varReMstSheet = vNewValue
End Property


Public Property Get IndMstPath() As String
    IndMstPath = varIndMstPath
End Property

Public Property Let IndMstPath(ByVal vNewValue As String)
    varIndMstPath = vNewValue
End Property

Public Property Get IndMstFile() As String
    IndMstFile = varIndMstFile
End Property

Public Property Let IndMstFile(ByVal vNewValue As String)
    varIndMstFile = vNewValue
End Property

Public Property Get IndMstSheet() As String
    IndMstSheet = varIndMstSheet
End Property

Public Property Let IndMstSheet(ByVal vNewValue As String)
    varIndMstSheet = vNewValue
End Property


Public Property Get CItemPath() As String
    CItemPath = varCItemPath
End Property

Public Property Let CItemPath(ByVal vNewValue As String)
    varCItemPath = vNewValue
End Property

Public Property Get CItemFile() As String
    CItemFile = varCItemFile
End Property

Public Property Let CItemFile(ByVal vNewValue As String)
    varCItemFile = vNewValue
End Property

Public Property Get CItemSheet() As String
    CItemSheet = varCItemSheet
End Property

Public Property Let CItemSheet(ByVal vNewValue As String)
    varCItemSheet = vNewValue
End Property


Public Property Get IIPDataPath() As String
    IIPDataPath = varIIPDataPath
End Property

Public Property Let IIPDataPath(ByVal vNewValue As String)
    varIIPDataPath = vNewValue
End Property

Public Property Get IIPDataFile() As String
    IIPDataFile = varIIPDataFile
End Property

Public Property Let IIPDataFile(ByVal vNewValue As String)
     varIIPDataFile = vNewValue
End Property

Public Property Get IIPDataSheet() As String
    IIPDataSheet = varIIPDataSheet
End Property

Public Property Let IIPDataSheet(ByVal vNewValue As String)
    varIIPDataSheet = vNewValue
End Property


Public Property Get ProductPath() As String
    ProductPath = varProductPath
End Property

Public Property Let ProductPath(ByVal vNewValue As String)
    varProductPath = vNewValue
End Property

Public Property Get ProductFile() As String
    ProductFile = varProductFile
End Property

Public Property Let ProductFile(ByVal vNewValue As String)
     varProductFile = vNewValue
End Property

Public Property Get ProductSheet() As String
    ProductSheet = varProductSheet
End Property

Public Property Let ProductSheet(ByVal vNewValue As String)
    varProductSheet = vNewValue
End Property


Public Property Get ShipPath() As String
    ShipPath = varShipPath
End Property

Public Property Let ShipPath(ByVal vNewValue As String)
    varShipPath = vNewValue
End Property

Public Property Get ShipFile() As String
    ShipFile = varShipFile
End Property

Public Property Let ShipFile(ByVal vNewValue As String)
     varShipFile = vNewValue
End Property

Public Property Get ShipSheet() As String
    ShipSheet = varShipSheet
End Property

Public Property Let ShipSheet(ByVal vNewValue As String)
    varShipSheet = vNewValue
End Property


Public Property Get InventoryPath() As String
    InventoryPath = varInventoryPath
End Property

Public Property Let InventoryPath(ByVal vNewValue As String)
    varInventoryPath = vNewValue
End Property

Public Property Get InventoryFile() As String
    InventoryFile = varInventoryFile
End Property

Public Property Let InventoryFile(ByVal vNewValue As String)
     varInventoryFile = vNewValue
End Property

Public Property Get InventorySheet() As String
    InventorySheet = varInventorySheet
End Property

Public Property Let InventorySheet(ByVal vNewValue As String)
    varInventorySheet = vNewValue
End Property


Public Property Get RatePath() As String
    RatePath = varRatePath
End Property

Public Property Let RatePath(ByVal vNewValue As String)
    varRatePath = vNewValue
End Property

Public Property Get RateFile() As String
    RateFile = varRateFile
End Property

Public Property Let RateFile(ByVal vNewValue As String)
     varRateFile = vNewValue
End Property

Public Property Get RateSheet() As String
    RateSheet = varRateSheet
End Property

Public Property Let RateSheet(ByVal vNewValue As String)
    varRateSheet = vNewValue
End Property

'コレクション'
Public Property Get colItems() As colItems
    If varColItems Is Nothing Then Set varColItems = New colItems
    Set colItems = varColItems
End Property

Public Property Set colItems(ByVal vNewValue As colItems)
    If varColItems Is Nothing Then Set varColItems = New colItems
    Set colItems = vNewValue
End Property

'
Public Property Get colReMsts() As colReMsts
    If varColReMsts Is Nothing Then Set varColReMsts = New colReMsts
    Set colReMsts = varColReMsts
End Property

Public Property Set colReMsts(ByVal vNewValue As colReMsts)
    If varColReMsts Is Nothing Then Set varColReMsts = New colReMsts
    Set colReMsts = vNewValue
End Property

'
Public Property Get colIndMsts() As colIndMsts
    If varColIndMsts Is Nothing Then Set varColIndMsts = New colIndMsts
    Set colIndMsts = varColIndMsts
End Property

Public Property Set colIndMsts(ByVal vNewValue As colIndMsts)
    If varColIndMsts Is Nothing Then Set varColIndMsts = New colIndMsts
    Set colIndMsts = vNewValue
End Property

'
Public Property Get colCItems() As colCItems
    If varColCItems Is Nothing Then Set varColCItems = New colCItems
    Set colCItems = varColCItems
End Property

Public Property Set colCItems(ByVal vNewValue As colCItems)
    If varColCItems Is Nothing Then Set varColCItems = New colCItems
    Set colCItems = vNewValue
End Property

'
Public Property Get colIIPDatas() As colIIPDatas
    If varColIIPDatas Is Nothing Then Set varColIIPDatas = New colIIPDatas
    Set colIIPDatas = varColIIPDatas
End Property

Public Property Set colIIPDatas(ByVal vNewValue As colIIPDatas)
    If varColIIPDatas Is Nothing Then Set varColIIPDatas = New colIIPDatas
    Set colIIPDatas = vNewValue
End Property


'ルートコレクションを閉じると配下のコレクションも削除
Private Sub Class_Terminate()
    Set varColItems = Nothing
    Set varColReMsts = Nothing
    Set varColIndMsts = Nothing
    Set varColCItems = Nothing
    Set varColIIPDatas = Nothing
End Sub

ワークブックを開いたときに、ファイルのパスやシート番号の既定値をTopシートから取得する。
Topシートがなければ処理不能。
Cells(1,2)の値がTemplateでなければ処理開始しない。
開始時に、Cells(1,2)の値はProcessingに変更し、ファイル名を「procIIP.xlsm」に変更して保存。
　　--- > テンプレートファイルは変更されない仕様。
[ThisWorkbook]

Option Explicit
'
Private Const PATHCLM As Integer = 4                        'Topシートからパスを取得する列
Private Const FILECLM As Integer = 8                        'Topシートからファイル名を取得する列
Private Const SHEETCLM As Integer = 12                      'Topシートからシート番号を取得する列
Private Const INITROW As Integer = 4                        '対象エクセルの情報開始行
Private Const SAVE_NAME As String = "procIIP.xlsm"          'テンプレートから名前を変更して処理
'
Private Sub Workbook_Open()
    Dim tmpSheet As Worksheet                               'シートのループ用シート
    Dim infoRow As Integer                                  'Topシートからパスなどを取得する行
    Dim svFileName As String                                '保存ァフィル名
    shTop.Activate
    Cells(1, 1).Select
    'Topシートが無ければ処理を継続しない。
    If TopExistCheck Then
        '処理開始
        'ルートクラスのインスタンス取得（共有）
        If tManage Is Nothing Then Set tManage = New clsManage
        infoRow = INITROW
        '保存ファイル名取得
        svFileName = ActiveWorkbook.Path & "\" & SAVE_NAME
        'Topシートからパス・ファイル名・シート番号の既定値を取得
        With tManage
            '保存場所
             .SavePath = Trim(Cells(infoRow, PATHCLM).Value)
             .SaveFile = Trim(Cells(infoRow, FILECLM).Value)
            '項目マスタ
             infoRow = infoRow + 1
            .ItemPath = Trim(Cells(infoRow, PATHCLM).Value)
            .ItemFile = Trim(Cells(infoRow, FILECLM).Value)
            .ItemSheet = Trim(Cells(infoRow, SHEETCLM).Value)
            '再掲マスタ
            infoRow = infoRow + 1
            .ReMstPath = Trim(Cells(infoRow, PATHCLM).Value)
            .ReMstFile = Trim(Cells(infoRow, FILECLM).Value)
            .ReMstSheet = Trim(Cells(infoRow, SHEETCLM).Value)
            '中国経産局 業種マスタ
            infoRow = infoRow + 1
            .IndMstPath = Trim(Cells(infoRow, PATHCLM).Value)
            .IndMstFile = Trim(Cells(infoRow, FILECLM).Value)
            .IndMstSheet = Trim(Cells(infoRow, SHEETCLM).Value)
            '中国経産局 品目マスタ
             infoRow = infoRow + 1
            .CItemPath = Trim(Cells(infoRow, PATHCLM).Value)
            .CItemFile = Trim(Cells(infoRow, FILECLM).Value)
            .CItemSheet = Trim(Cells(infoRow, SHEETCLM).Value)
            'Data
             infoRow = infoRow + 1
            .IIPDataPath = Trim(Cells(infoRow, PATHCLM).Value)
            .IIPDataFile = Trim(Cells(infoRow, FILECLM).Value)
            .IIPDataSheet = Trim(Cells(infoRow, SHEETCLM).Value)
        End With
        '「名前を変えて処理」テンプレートを編集したいときはここで止める
        If MsgBox("処理を継続しますか？", vbQuestion + vbYesNo, "処理継続") = vbYes Then
            'Killは確認なく削除するが、ファイルがないとエラーになるのでDirで確認してからKill
            If Dir(svFileName) <> "" Then
                Kill svFileName
            End If
            'モードをTemplateから処理に変更してから保存
            Cells(1, 2).Value = "Processing"
            ActiveWorkbook.SaveAs Filename:=svFileName
            flgContinue = True
        Else
            flgContinue = False
        End If

        '主処理へ
        If flgContinue Then MainRtn
    End If
End Sub

'Topページがないと開始不能。またCells(1, 2)がTemplateでないと既に処理されたファイルと思われるので処理開始しない。
Private Function TopExistCheck() As Boolean
    TopExistCheck = False
    On Error GoTo existError
    shTop.Select
    If Cells(1, 2).Value = "Template" Then
        TopExistCheck = True
    Else
    If MsgBox("実行済みエクセルです" & vbCrLf & "処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "エクセル終了?") = vbYes Then Application.Quit
    End If
    Exit Function
existError:
    If MsgBox("Topシートが見つかりません" & vbCrLf & "処理を中断しますか？", vbCritical + vbDefaultButton2 + vbYesNo, "開始不能!!エクセル終了?") = vbYes Then Application.Quit
End Function

モジュールの初めに、上記で取得したファイルパスやシートNo.を既定値としてそれぞれのパスをフォームで確認する。

[frmSaveName]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    txtXlPath.Text = tManage.SavePath & "\" & Format(DateAdd("m", -1, Now()), "yymm") & "_" & tManage.SaveFile
End Sub


'既定のファイル名を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .SaveFile = txtXlPath.Text
    End With
    Unload Me
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
    If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
    End If
End Sub

[frmItems]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.ItemPath & "\" & tManage.ItemFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.ItemPath & "\" & tManage.ItemFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.ItemFile = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .ItemFile = LblXlPath.Caption
        .ItemSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルを開いてのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.ItemSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.ItemSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
    If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
    End If
End Sub

[frmRemst]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.ReMstPath & "\" & tManage.ReMstFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.ReMstPath & "\" & tManage.ReMstFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.ReMstFile = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .ReMstFile = LblXlPath.Caption
        .ReMstSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.ItemSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.ItemSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
    If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
    End If
End Sub

[frmIndMst]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.IndMstPath & "\" & tManage.IndMstFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.IndMstPath & "\" & tManage.IndMstFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.IndMstPath = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .IndMstFile = LblXlPath.Caption
        .IndMstSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルを開いてのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.IndMstSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.IndMstSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
    If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
    End If
End Sub

[frmCItem]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.CItemPath & "\" & tManage.CItemFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.CItemPath & "\" & tManage.CItemFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.CItemFile = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .CItemFile = LblXlPath.Caption
        .CItemSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルを開いてのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.CItemSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.CItemSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
     If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
     End If
End Sub
Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.CItemPath & "\" & tManage.CItemFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.CItemPath & "\" & tManage.CItemFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.CItemFile = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .CItemFile = LblXlPath.Caption
        .CItemSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルを開いてのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.CItemSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.CItemSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
     If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
     End If
End Sub

[frmIIPData]

Option Explicit

'フォーム読み込み時に既定のパス、ファイル名、シート名を表示する
Private Sub UserForm_Initialize()
    If tManage Is Nothing Then Set tManage = New clsManage
    LblXlPath.Caption = tManage.IIPDataPath & "\" & tManage.IIPDataFile
    DispXlSheets
End Sub

'ファイル選択ボタンクリックで、ファイル選択ダイアログ表示
Private Sub CmdDialog_Click()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = tManage.IIPDataPath & "\" & tManage.IIPDataFile
        .Show
        LblXlPath.Caption = .SelectedItems(1)
        tManage.IIPDataFile = .SelectedItems(1)
    End With
    DispXlSheets
End Sub

'既定のファイル名とシート番号を書き換えてフォームを閉じる
Private Sub CmdGo_Click()
  If LstXL.ListIndex = -1 Then Exit Sub
    If tManage Is Nothing Then Set tManage = New clsManage
    With tManage
        .IIPDataFile = LblXlPath.Caption
        .IIPDataSheet = LstXL.ListIndex + 1
    End With
    Unload Me
End Sub

'選択されたエクセルファイルのシート名をリスト
Private Sub DispXlSheets()
    Dim tBookName As String
    'シートリストの初期化
    LstXL.Clear
    '指定エクセルを開いてのシートをシートリストにセット
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(LblXlPath.Caption, False, True)
    tBookName = objXLBook.Name
'
    For Each objXLSheet In objXLBook.Worksheets
        LstXL.AddItem objXLSheet.Name
    Next objXLSheet
    ' 開いたエクセルを閉じる
    objXLBook.Close SaveChanges:=False
    Set objXLSheet = Nothing
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    '既定のシートをリストのデフォルトに設定
    If tManage.IIPDataSheet > LstXL.ListCount Then
        LstXL.ListIndex = 0
    Else
        LstXL.ListIndex = tManage.IIPDataSheet - 1
    End If
End Sub

'処理そのものを中止する。
Private Sub CmdClose_Click()
     If MsgBox("処理を中断しますか？", vbQuestion + vbDefaultButton2 + vbYesNo, "処理終了") = vbYes Then
        flgContinue = False
        Unload Me
     End If
End Sub

標準モジュールで上記フォームを順次オープンし、確定したファイルパスからエクセルデータを読み込んで、Class & Collectionで保持する。
保持したClass & Collectionから内容をシートに展開してみた。
データをウェイトと絡ませて作成したシートを完成形として、新しいBブックに出力して、余計なシートを削除し、フォームで得たSaveファイル名として保存する。（すでに同名のファイルがあると、上書きのメッセージを表示して保存）
[modMain]

Option Explicit

Public tManage As clsManage                 'ルートクラスのインスタンスを共有
Public flgContinue As Boolean
Public outputBook As Workbook

'メインルーチン
Public Sub MainRtn()
    Dim pstArray
    Dim curRow As Integer
    Dim curRow1 As Integer
    Dim curRow2 As Integer
    Dim curRow3 As Integer
    Dim curRow4 As Integer
    Dim curRow5 As Integer
    '
    Dim tItems As colItems
    Dim tReMsts As colReMsts
    Dim tIndMsts As colIndMsts
    Dim tCItems As colCItems
    Dim tIIPDatas As colIIPDatas
    
    Dim tmpIndId As Integer
    Dim tmpIndName As String
    '
    Dim tItem As clsItem
    Dim tReMst As clsReMst
    Dim tIndMst As clsIndMst
    Dim tCItem As clsCItem
    Dim tIIPData As clsIIPData
    '
    Dim ParentName As String
    Dim selRange As Range
    
    Dim sumP As Currency                    '生産ウェイト合計
    Dim sumS As Currency                    '出荷ウェイト合計
    Dim sumI As Currency                    '在庫ウェイト合計
    Dim sumR As Currency                    '在庫率ウェイト合計
    Dim bolReID As Boolean
    'オプション試し処理
    Dim sum1P As Currency
    Dim sum2P As Currency
    Dim sum3P As Currency
    Dim sum4P As Currency
    Dim sum1S As Currency
    Dim sum2S As Currency
    Dim sum3S As Currency
    Dim sum4S As Currency
    Dim sum1I As Currency
    Dim sum2I As Currency
    Dim sum3I As Currency
    Dim sum4I As Currency
    Dim sum1R As Currency
    Dim sum2R As Currency
    Dim sum3R As Currency
    Dim sum4R As Currency
        
    Application.ScreenUpdating = False
    If tManage Is Nothing Then Set tManage = New clsManage
    flgContinue = True
    '外部エクセル選択フォーム表示
    frmSaveName.Show
    If flgContinue Then frmItem.Show
    If flgContinue Then frmRemst.Show
    If flgContinue Then frmIndMst.Show
    If flgContinue Then frmCItem.Show
    If flgContinue Then frmIIPData.Show
    If flgContinue Then
     '外部エクセルを開いて読み込みクラス＆コレクションに格納
        With tManage
             Set tReMsts = .colReMsts.GetXLData
             Set tItems = .colItems.GetXLData
             Set tIndMsts = .colIndMsts.GetXLData
             Set tCItems = .colCItems.GetXLData
             Set tIIPDatas = .colIIPDatas.GetXLData
        End With
'            '例としてコレクション内容をOutPut
            shList.Select
            Set selRange = Cells(1, 1).CurrentRegion
            selRange.Offset(1, 0).ClearContents
            '
            curRow = 2
            sumP = 0
            sumS = 0
            sumI = 0
            sumR = 0
            '
            sum1P = 0
            sum1S = 0
            sum1I = 0
            sum1R = 0
            '
            sum2P = 0
            sum2S = 0
            sum2I = 0
            sum2R = 0
            '
            sum3P = 0
            sum3S = 0
            sum3I = 0
            sum3R = 0
            '
            sum4P = 0
            sum4S = 0
            sum4I = 0
            sum4R = 0
            '
            For Each tItem In tItems
                With tItem
                     If .CountChildren = 0 And .Level >= 5 Then
                         sumP = sumP + .ProductW
                         sumS = sumS + .ShipW
                         sumI = sumI + .InventoryW
                         sumR = sumR + .RationW
                     End If
                     Select Case Trim(.RefCtg)
                     Case "①"
                         sum1P = sum1P + .ProductW
                         sum1S = sum1S + .ShipW
                         sum1I = sum1I + .InventoryW
                         sum1R = sum1R + .RationW
                     Case "②"
                         sum2P = sum2P + .ProductW
                         sum2S = sum2S + .ShipW
                         sum2I = sum2I + .InventoryW
                         sum2R = sum2R + .RationW
                     Case "③"
                         sum3P = sum3P + .ProductW
                         sum3S = sum3S + .ShipW
                         sum3I = sum3I + .InventoryW
                         sum3R = sum3R + .RationW
                     Case "④"
                         sum4P = sum4P + .ProductW
                         sum4S = sum4S + .ShipW
                         sum4I = sum4I + .InventoryW
                         sum4R = sum4R + .RationW
                     End Select
                     '
                     ParentName = ""
                     If Trim(.ParentId) <> "" Then
                         ParentName = tManage.colItems.GetItemByIndex(.ParentId).Name
                     End If
                     pstArray = Array(ParentName, .Id, .Name, .RefCtg, .FinancialCtg, .PurposeCtg, .Unit, .ProductW, .ShipW, .InventoryW, .RationW, .Level, .ParentId, .ReId, .CountChildren)
                     Range(Cells(curRow, 1), Cells(curRow, 15)) = pstArray
                     curRow = curRow + 1
                     Application.ScreenUpdating = False
                End With
         Next
         pstArray = Array(sumP, sumS, sumI, sumR)
         Range(Cells(curRow, 8), Cells(curRow, 11)) = pstArray
         curRow = curRow + 1
         pstArray = Array("①", sum1P, sum1S, sum1I, sum1R)
         Range(Cells(curRow, 7), Cells(curRow, 11)) = pstArray
         curRow = curRow + 1
         pstArray = Array("②", sum2P, sum2S, sum2I, sum2R)
         Range(Cells(curRow, 7), Cells(curRow, 11)) = pstArray
         curRow = curRow + 1
         pstArray = Array("③", sum3P, sum3S, sum3I, sum3R)
         Range(Cells(curRow, 7), Cells(curRow, 11)) = pstArray
         curRow = curRow + 1
         pstArray = Array("④", sum4P, sum4S, sum4I, sum4R)
         Range(Cells(curRow, 7), Cells(curRow, 11)) = pstArray
         '
         'データシートを展開しながら、業種ウェイトクラス、品目ウェイトクラスにデータ値を書き込む
         shData.Select
         Set selRange = Cells(1, 1).CurrentRegion
         selRange.Offset(1, 0).ClearContents
         curRow = 2
         For Each tIIPData In tIIPDatas
            With tIIPData
                '品目ウェイトクラス
                Set tCItem = tCItems.GetCItemByIndex(.Id)
                If Not tCItem Is Nothing Then
                    tCItem.ProductD = tCItem.ProductD + .ProductD
                    tCItem.ShipD = tCItem.ShipD + .ShipD
                    tCItem.InventoryD = tCItem.InventoryD + .InventoryD
                    tCItem.RationD = tCItem.RationD + .RationD
                End If
                Set tCItem = Nothing
                '業種ウェイトクラス
                Set tIndMst = tIndMsts.GetIndMstByIndex(.ParentId)
                If Not tIndMst Is Nothing Then
                    tIndMst.ProductD = tIndMst.ProductD + .ProductD
                    tIndMst.ShipD = tIndMst.ShipD + .ShipD
                    tIndMst.InventoryD = tIndMst.InventoryD + .InventoryD
                    tIndMst.RationD = tIndMst.RationD + .RationD
                    '業種ウェイトクラスに親がある場合は、その親のクラスにもデータ追加
                    If tIndMst.ParentId <> 0 Then
                        tmpIndId = tIndMst.ParentId
                        Set tIndMst = Nothing
                        Set tIndMst = tIndMsts(tmpIndId)
                        If Not tIndMst Is Nothing Then
                            tIndMst.ProductD = tIndMst.ProductD + .ProductD
                            tIndMst.ShipD = tIndMst.ShipD + .ShipD
                            tIndMst.InventoryD = tIndMst.InventoryD + .InventoryD
                            tIndMst.RationD = tIndMst.RationD + .RationD
                        End If
                    End If
                End If
                pstArray = Array(.Id, .Name, .ProductD, .ShipD, .InventoryD, .RationD, .ParentId, .ParentName)
                Range(Cells(curRow, 1), Cells(curRow, 8)) = pstArray
                curRow = curRow + 1
            End With
         Next
         '
         '業種ウェイトを展開
         shInd.Select
         Set selRange = Cells(1, 1).CurrentRegion
         selRange.Offset(1, 0).ClearContents
         curRow = 2
         For Each tIndMst In tIndMsts
            With tIndMst
                tmpIndName = .IndName
                If .ParentId <> 0 Then tmpIndName = "  " & tmpIndName
                pstArray = Array(.SrgId, .IndId, tmpIndName, .ItemFrom, .ItemTo, .ProductW, .ShipW, .InventoryW, .RationW, .ParentId, .Haschild, .ProductD, .ShipD, .InventoryD, .RationD)
                Range(Cells(curRow, 1), Cells(curRow, 15)) = pstArray
                curRow = curRow + 1
            End With
         Next
        '
        '品目ウェイトを展開しながら再掲マスタのウェイトの集計を行う（今回データは集計していない）
         shCItem.Select
         Set selRange = Cells(1, 1).CurrentRegion
         selRange.Offset(1, 0).ClearContents
         curRow = 2
         For Each tCItem In tCItems
             With tCItem
                 If .ReId > 0 Then
                     For Each tReMst In tManage.colReMsts
                         '再掲マスタの値が登録されている場合 （すでに済んだ値はスルー）
                         If tReMst.ReVal > .ReId Then Exit For
                         bolReID = False
                         '再掲マスタに登録された検索値とANDをとって、検索値と同じになれば対象（ビット演算）
                         bolReID = ((tReMst.ReVal And .ReId) = tReMst.ReVal)
                         If bolReID Then
                             tReMst.ProductW = tReMst.ProductW + .ProductW
                             tReMst.ShipW = tReMst.ShipW + .ShipW
                             tReMst.InventoryW = tReMst.InventoryW + .InventoryW
                             tReMst.RationW = tReMst.RationW + .RationW
                         End If
                     Next
                 End If
                 pstArray = Array(.Id, .Name, .ProductW, .ShipW, .InventoryW, .RationW, .ParentId, .ParentName, .ReId, .ProductD, .ShipD, .InventoryD, .RationD)
                 Range(Cells(curRow, 1), Cells(curRow, 13)) = pstArray
                 curRow = curRow + 1
             End With
         Next

         '
         '再掲マスタを展開
         shMst.Select
         Set selRange = Cells(1, 1).CurrentRegion
         selRange.Offset(1, 0).ClearContents
         curRow = 2
         For Each tReMst In tReMsts
             With tReMst
                 pstArray = Array(.ReId, .Name, .ReVal, .ProductW, .ShipW, .InventoryW, .RationW)
                 Range(Cells(curRow, 1), Cells(curRow, 7)) = pstArray
                 curRow = curRow + 1
             End With
         Next
'
        Call DataOutput
'
        shTop.Select
        If Not tManage Is Nothing Then Set tManage = Nothing
        ActiveWorkbook.Save
        outputBook.Activate
        Application.ScreenUpdating = True
        End If
End Sub

'最終アウトプットを別ファイルとする
Private Sub DataOutput()
    Dim selRange As Range
    Dim pstArray
    Dim cMax As Integer
    Dim i As Integer
    Dim tIndMsts As colIndMsts
    Dim ws As Worksheet
    Dim tmpName As String
    Dim tmpIndName As String
    
    Application.ScreenUpdating = False
    
    shOutPut.Select
    Set selRange = Cells(1, 1).CurrentRegion
    selRange.Offset(1, 0).ClearContents
    Set tIndMsts = tManage.colIndMsts
    cMax = tIndMsts.Count
    'For EachでなくFor Nextを使用してみた。順序を確認するため
    For i = 1 To cMax
        With tIndMsts(i)
            tmpIndName = .IndName
            If .ParentId <> 0 Then tmpIndName = "  " & tmpIndName
            pstArray = Array(.IndId, tmpIndName, .ProductW, .ShipW, .InventoryW, .RationW, .ProductD, .ShipD, .InventoryD, .RationD)
            Range(Cells(i + 1, 1), Cells(i + 1, 10)) = pstArray
        End With
    Next i
    '
    '新しいブックに出力。余計なシートを削除。名前を付けて保存、対象のブックを保持（最終的にアクティブにするため）
    tmpName = shOutPut.Name
    Workbooks.Add
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets(tmpName).Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
    Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.CodeName <> "shOutPut" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs tManage.SaveFile
    Set outputBook = ActiveWorkbook
    ThisWorkbook.Activate
End Sub

クラス
[clsItem]

Option Explicit

     Private varId As String                    '番号
     Private varName As String                  '名称
     Private varRefCtg As String                '参考分類
     Private varFinancialCtg As String          '財分類
     Private varPurposeCtg As String            '用途分類
     Private varUnit As String                  '単位
     Private varProductW As Currency            'ウエイト生産
     Private varShipW As Currency               'ウエイト出荷
     Private varInventoryW As Currency          'ウエイト在庫
     Private varRationW As Currency             'ウエイト在庫率
     Private varLevel As Integer                '階層レベル
     Private varParentId As String              '階層親番号
     Private varReId As Integer                 '対象再掲項目ID値合計
     Private varCountChildren                   '階層直下の項目数

Private Sub Class_Initialize()
     varId = ""
     varName = ""
     varRefCtg = ""
     varFinancialCtg = ""
     varPurposeCtg = ""
     varUnit = ""
     varProductW = 0
     varShipW = 0
     varInventoryW = 0
     varRationW = 0
     varLevel = 0
     varParentId = ""
     varReId = 0
     varCountChildren = 0
End Sub

Public Property Get Id() As String
    Id = varId
End Property

Public Property Let Id(ByVal vNewValue As String)
    varId = vNewValue
End Property

Public Property Get Name() As String
    Name = varName
End Property

Public Property Let Name(ByVal vNewValue As String)
    varName = vNewValue
End Property

Public Property Get RefCtg() As String
    RefCtg = varRefCtg
End Property

Public Property Let RefCtg(ByVal vNewValue As String)
    varRefCtg = vNewValue
End Property

Public Property Get FinancialCtg() As String
    FinancialCtg = varFinancialCtg
End Property

Public Property Let FinancialCtg(ByVal vNewValue As String)
    varFinancialCtg = vNewValue
End Property

Public Property Get PurposeCtg() As String
    PurposeCtg = varPurposeCtg
End Property

Public Property Let PurposeCtg(ByVal vNewValue As String)
    varPurposeCtg = vNewValue
End Property

Public Property Get Unit() As String
    Unit = varUnit
End Property

Public Property Let Unit(ByVal vNewValue As String)
    varUnit = vNewValue
End Property

Public Property Get ProductW() As Currency
    ProductW = varProductW
End Property

Public Property Let ProductW(ByVal vNewValue As Currency)
    varProductW = vNewValue
End Property

Public Property Get ShipW() As Currency
    ShipW = varShipW
End Property

Public Property Let ShipW(ByVal vNewValue As Currency)
    varShipW = vNewValue
End Property

Public Property Get InventoryW() As Currency
    InventoryW = varInventoryW
End Property

Public Property Let InventoryW(ByVal vNewValue As Currency)
    varInventoryW = vNewValue
End Property

Public Property Get RationW() As Currency
    RationW = varRationW
End Property

Public Property Let RationW(ByVal vNewValue As Currency)
    varRationW = vNewValue
End Property

Public Property Get Level() As Integer
    Level = varLevel
End Property

Public Property Let Level(ByVal vNewValue As Integer)
    varLevel = vNewValue
End Property

Public Property Get ParentId() As String
    ParentId = varParentId
End Property

Public Property Let ParentId(ByVal vNewValue As String)
    varParentId = vNewValue
End Property

Public Property Get ReId() As Integer
    ReId = varReId
End Property

Public Property Let ReId(ByVal vNewValue As Integer)
    varReId = vNewValue
End Property

Public Property Get CountChildren() As Integer
    CountChildren = varCountChildren
End Property

Public Property Let CountChildren(ByVal vNewValue As Integer)
    varCountChildren = vNewValue
End Property

[clsReMst]

Option Explicit

Private varReId As Integer          '再掲項目ID
Private varName As String           '再掲項目名称
Private varReVal As Integer         '再掲項目ID値(2^0,2^1,2^2,2^3,,,)
Private varProductW As Currency     'ウエイト生産
Private varShipW As Currency        'ウエイト出荷
Private varInventoryW As Currency   'ウエイト在庫
Private varRationW As Currency      'ウエイト在庫率

Private Sub Class_Initialize()
     varReId = 0
     varName = ""
     varReVal = 0
     varProductW = 0
     varShipW = 0
     varInventoryW = 0
     varRationW = 0
End Sub

Public Property Get ReId() As Integer
    ReId = varReId
End Property

Public Property Let ReId(ByVal vNewValue As Integer)
    varReId = vNewValue
End Property

Public Property Get Name() As String
    Name = varName
End Property

Public Property Let Name(ByVal vNewValue As String)
    varName = vNewValue
End Property

Public Property Get ReVal() As Integer
    ReVal = varReVal
End Property

Public Property Let ReVal(ByVal vNewValue As Integer)
    varReVal = vNewValue
End Property

Public Property Get ProductW() As Currency
    ProductW = varProductW
End Property

Public Property Let ProductW(ByVal vNewValue As Currency)
    varProductW = vNewValue
End Property

Public Property Get ShipW() As Currency
    ShipW = varShipW
End Property

Public Property Let ShipW(ByVal vNewValue As Currency)
    varShipW = vNewValue
End Property

Public Property Get InventoryW() As Currency
    InventoryW = varInventoryW
End Property

Public Property Let InventoryW(ByVal vNewValue As Currency)
    varInventoryW = vNewValue
End Property

Public Property Get RationW() As Currency
    RationW = varRationW
End Property

Public Property Let RationW(ByVal vNewValue As Currency)
    varRationW = vNewValue
End Property

[clsIndMst]

Option Explicit
    
    Private varSrgId As Integer           'SurrogateID(連番キー)
    Private varIndId As Integer           '業種ID
    Private varIndName As String         '業種名
    Private varItemFrom As String         '対象品目開始ID
    Private varItemTo As String           '対象品目終了ID
    Private varProductW As Currency       'ウエイト生産
    Private varShipW As Currency          'ウエイト出荷
    Private varInventoryW As Currency     'ウエイト在庫
    Private varRationW As Currency        'ウエイト在庫率
    Private varParentId As Integer        '親SurrogeteID
    Private varHasChild As Boolean        '子を持つ場合True
    Private varProductD As Currency            'Data生産
    Private varShipD As Currency               'Data出荷
    Private varInventoryD As Currency          'Data在庫
    Private varRationD As Currency             'Data在庫率計

Private Sub Class_Initialize()
     varSrgId = 0
     varIndId = 0
     varIndName = ""
     varItemFrom = ""
     varItemTo = ""
     varProductW = 0
     varShipW = 0
     varInventoryW = 0
     varRationW = 0
     varParentId = 0
     varHasChild = False
     varProductD = 0
     varShipD = 0
     varInventoryD = 0
     varRationD = 0
End Sub

Public Property Get SrgId() As Integer
    SrgId = varSrgId
End Property

Public Property Let SrgId(ByVal vNewValue As Integer)
    varSrgId = vNewValue
End Property

Public Property Get IndId() As Integer
    IndId = varIndId
End Property

Public Property Let IndId(ByVal vNewValue As Integer)
    varIndId = vNewValue
End Property

Public Property Get IndName() As String
    IndName = varIndName
End Property

Public Property Let IndName(ByVal vNewValue As String)
    varIndName = vNewValue
End Property

Public Property Get ItemFrom() As String
    ItemFrom = varItemFrom
End Property

Public Property Let ItemFrom(ByVal vNewValue As String)
    varItemFrom = vNewValue
End Property

Public Property Get ItemTo() As String
    ItemTo = varItemTo
End Property

Public Property Let ItemTo(ByVal vNewValue As String)
    varItemTo = vNewValue
End Property

Public Property Get ProductW() As Currency
    ProductW = varProductW
End Property

Public Property Let ProductW(ByVal vNewValue As Currency)
    varProductW = vNewValue
End Property

Public Property Get ShipW() As Currency
    ShipW = varShipW
End Property

Public Property Let ShipW(ByVal vNewValue As Currency)
    varShipW = vNewValue
End Property

Public Property Get InventoryW() As Currency
    InventoryW = varInventoryW
End Property

Public Property Let InventoryW(ByVal vNewValue As Currency)
    varInventoryW = vNewValue
End Property

Public Property Get RationW() As Currency
    RationW = varRationW
End Property

Public Property Let RationW(ByVal vNewValue As Currency)
    varRationW = vNewValue
End Property

Public Property Get ParentId() As Integer
    ParentId = varParentId
End Property

Public Property Let ParentId(ByVal vNewValue As Integer)
    varParentId = vNewValue
End Property

Public Property Get Haschild() As Boolean
    Haschild = varHasChild
End Property

Public Property Let Haschild(ByVal vNewValue As Boolean)
    varHasChild = vNewValue
End Property

Public Property Get ProductD() As Currency
    ProductD = varProductD
End Property

Public Property Let ProductD(ByVal vNewValue As Currency)
    varProductD = vNewValue
End Property

Public Property Get ShipD() As Currency
    ShipD = varShipD
End Property

Public Property Let ShipD(ByVal vNewValue As Currency)
    varShipD = vNewValue
End Property

Public Property Get InventoryD() As Currency
    InventoryD = varInventoryD
End Property

Public Property Let InventoryD(ByVal vNewValue As Currency)
    varInventoryD = vNewValue
End Property

Public Property Get RationD() As Currency
    RationD = varRationD
End Property

Public Property Let RationD(ByVal vNewValue As Currency)
    varRationD = vNewValue
End Property

[clsCItem]

Option Explicit

     Private varId As String                    '番号
     Private varName As String                  '名称
     Private varProductW As Currency            'ウエイト生産
     Private varShipW As Currency               'ウエイト出荷
     Private varInventoryW As Currency          'ウエイト在庫
     Private varRationW As Currency             'ウエイト在庫率
     Private varParentId As Integer             '業種親階層ID
     Private varParentName As String             '業種親階層ID
     Private varReId As Integer                 '対象再掲項目ID値合計
     Private varProductD As Currency            'Data生産
     Private varShipD As Currency               'Data出荷
     Private varInventoryD As Currency          'Data在庫
     Private varRationD As Currency             'Data在庫率計

Private Sub Class_Initialize()
     varId = ""
     varName = ""
     varProductW = 0
     varShipW = 0
     varInventoryW = 0
     varRationW = 0
     varParentId = 0
     varParentName = ""
     varReId = 0
     varProductD = 0
     varShipD = 0
     varInventoryD = 0
     varRationD = 0
End Sub

Public Property Get Id() As String
    Id = varId
End Property

Public Property Let Id(ByVal vNewValue As String)
    varId = vNewValue
End Property

Public Property Get Name() As String
    Name = varName
End Property

Public Property Let Name(ByVal vNewValue As String)
    varName = vNewValue
End Property

Public Property Get ProductW() As Currency
    ProductW = varProductW
End Property

Public Property Let ProductW(ByVal vNewValue As Currency)
    varProductW = vNewValue
End Property

Public Property Get ShipW() As Currency
    ShipW = varShipW
End Property

Public Property Let ShipW(ByVal vNewValue As Currency)
    varShipW = vNewValue
End Property

Public Property Get InventoryW() As Currency
    InventoryW = varInventoryW
End Property

Public Property Let InventoryW(ByVal vNewValue As Currency)
    varInventoryW = vNewValue
End Property

Public Property Get RationW() As Currency
    RationW = varRationW
End Property

Public Property Let RationW(ByVal vNewValue As Currency)
    varRationW = vNewValue
End Property


Public Property Get ParentId() As Integer
    ParentId = varParentId
End Property

Public Property Let ParentId(ByVal vNewValue As Integer)
    varParentId = vNewValue
End Property

Public Property Get ParentName() As String
    ParentName = varParentName
End Property

Public Property Let ParentName(ByVal vNewValue As String)
    varParentName = vNewValue
End Property

Public Property Get ReId() As Integer
    ReId = varReId
End Property

Public Property Let ReId(ByVal vNewValue As Integer)
    varReId = vNewValue
End Property

Public Property Get ProductD() As Currency
    ProductD = varProductD
End Property

Public Property Let ProductD(ByVal vNewValue As Currency)
    varProductD = vNewValue
End Property

Public Property Get ShipD() As Currency
    ShipD = varShipD
End Property

Public Property Let ShipD(ByVal vNewValue As Currency)
    varShipD = vNewValue
End Property

Public Property Get InventoryD() As Currency
    InventoryD = varInventoryD
End Property

Public Property Let InventoryD(ByVal vNewValue As Currency)
    varInventoryD = vNewValue
End Property

Public Property Get RationD() As Currency
    RationD = varRationD
End Property

Public Property Let RationD(ByVal vNewValue As Currency)
    varRationD = vNewValue
End Property

[clsIIPData]

Option Explicit

     Private varId As String                          '番号
     Private varName As String                   '名称
     Private varProductD As Currency         'Data生産
     Private varShipD As Currency               'Data出荷
     Private varInventoryD As Currency       'Data在庫
     Private varRationD As Currency            'Data在庫率計
     Private varParentId As Integer              '業種親階層ID
     Private varParentName As String           '業種親階層ID

Private Sub Class_Initialize()
     varId = ""
     varName = ""
     varProductD = 0
     varShipD = 0
     varInventoryD = 0
     varRationD = 0
     varParentId = 0
     varParentName = ""
End Sub

Public Property Get Id() As String
    Id = varId
End Property

Public Property Let Id(ByVal vNewValue As String)
    varId = vNewValue
End Property

Public Property Get Name() As String
    Name = varName
End Property

Public Property Let Name(ByVal vNewValue As String)
    varName = vNewValue
End Property

Public Property Get ProductD() As Currency
    ProductD = varProductD
End Property

Public Property Let ProductD(ByVal vNewValue As Currency)
    varProductD = vNewValue
End Property

Public Property Get ShipD() As Currency
    ShipD = varShipD
End Property

Public Property Let ShipD(ByVal vNewValue As Currency)
    varShipD = vNewValue
End Property

Public Property Get InventoryD() As Currency
    InventoryD = varInventoryD
End Property

Public Property Let InventoryD(ByVal vNewValue As Currency)
    varInventoryD = vNewValue
End Property

Public Property Get RationD() As Currency
    RationD = varRationD
End Property

Public Property Let RationD(ByVal vNewValue As Currency)
    varRationD = vNewValue
End Property

Public Property Get ParentId() As Integer
    ParentId = varParentId
End Property

Public Property Let ParentId(ByVal vNewValue As Integer)
    varParentId = vNewValue
End Property

Public Property Get ParentName() As String
    ParentName = varParentName
End Property

Public Property Let ParentName(ByVal vNewValue As String)
    varParentName = vNewValue
End Property

コレクション　
[colItems]

Option Explicit
Private mCol As Collection

Const INITROW = 2       '空白を除いたデータの開始行
Const INITCLM = 2       '空白を除いたデータの開始列
Const TARGETROW = 4     'アクティブセル内のタイトルなどの余分なヘッダー行数を除いたデータの開始行

'メンバー追加
Public Function Add(Id As String, Name As String, RefCtg As String, FinancialCtg As String, PurposeCtg As String, Unit As String, _
                ProductW As Currency, ShipW As Currency, InventoryW As Currency, RationW As Currency, _
                Level As Integer, ParentId As String, ReId As Integer, CountChildren As Integer, Optional sKey As String) As clsItem
    Dim objNewMember As clsItem
    Set objNewMember = New clsItem
    With objNewMember
        .Id = Id
        .Name = Name
        .RefCtg = RefCtg
        .FinancialCtg = FinancialCtg
        .PurposeCtg = PurposeCtg
        .Unit = Unit
        .ProductW = ProductW
        .ShipW = ShipW
        .InventoryW = InventoryW
        .RationW = RationW
        .Level = Level
        .ParentId = ParentId
        .ReId = ReId
        .CountChildren = CountChildren
    End With
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

'キーまたは番号でメンバー取得
Public Property Get Item(vntIndexKey As Variant) As clsItem
  Set Item = mCol(vntIndexKey)
End Property

'メンバー数を取得
Public Property Get Count() As Long
    Count = mCol.Count
End Property

'メンバーを削除
Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'メンバー列挙（For Each に必要)
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

'エクセルを開いて対象シートを読み、行の情報からクラスを作成し、コレクションに追加
Public Function GetXLData() As colItems
    Application.ScreenUpdating = False
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    
    Dim re As Object                       '正規表現RegExpオブジェクト実行時バインディング
    
    Dim RangeArray                         'データを配列に取得
    Dim strRange As String                 'A1形式のレンジ取得文字列
    
    Dim curRow As Integer
    Dim EndRow As Integer
    
    Dim varId As String                    '番号
    Dim varName As String                  '名称
    Dim varRefCtg As String                '参考分類
    Dim varFinancialCtg As String          '財分類
    Dim varPurposeCtg As String            '用途分類
    Dim varUnit As String                  '単位
    Dim varProductW As Currency            'ウエイト生産
    Dim varShipW As Currency               'ウエイト出荷
    Dim varInventoryW As Currency          'ウエイト在庫
    Dim varRationW As Currency             'ウエイト在庫率
    Dim varLevel As Integer                '階層レベル
    Dim varParentId As String              '階層親番号
    Dim varReId As Integer                 '対象再掲項目ID値合計
    Dim varCountChildren As Integer        '所属項目数
    Dim preLevel As Integer                '直前のレベル保持
    Dim tmpLevel0 As String
    Dim tmpLevel1 As String
    Dim tmpLevel2 As String
    Dim tmpLevel3 As String
    Dim tmpLevel4 As String
    Dim tmpLevel5 As String
    Dim cntChildren As Integer
    Set GetXLData = Nothing
    
    '正規表現RegExpのバインディング
    Set re = CreateObject("VBScript.RegExp")
    '
    ClearAllMember
    
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(tManage.ItemFile, True, True)
    
    With objXLBook.Worksheets(CInt(tManage.ItemSheet))
        strRange = .Cells(INITROW, INITCLM).CurrentRegion.Address
        EndRow = CLng(Mid(strRange, 9))
        '対象のRange取得
        RangeArray = .Range(strRange).Value
    End With
    preLevel = 0
    '対象のRangeをループ
    For curRow = TARGETROW To EndRow - INITROW + 1
        varId = Trim(RangeArray(curRow, 1))
        If Trim(RangeArray(curRow, 2)) <> "" Then
            varName = Trim(RangeArray(curRow, 2))
            varLevel = 0
            tmpLevel0 = Trim(RangeArray(curRow, 1))
            tmpLevel1 = ""
            tmpLevel2 = ""
            tmpLevel3 = ""
            tmpLevel4 = ""
            tmpLevel5 = ""
            varParentId = ""
        ElseIf Trim(RangeArray(curRow, 3)) <> "" Then
            varName = Trim(RangeArray(curRow, 3))
            varLevel = 1
            tmpLevel1 = Trim(RangeArray(curRow, 1))
            tmpLevel2 = ""
            tmpLevel3 = ""
            tmpLevel4 = ""
            tmpLevel5 = ""
            varParentId = tmpLevel0
        ElseIf Trim(RangeArray(curRow, 4)) <> "" Then
            varName = Trim(RangeArray(curRow, 4))
            varLevel = 2
            tmpLevel2 = Trim(RangeArray(curRow, 1))
            tmpLevel3 = ""
            tmpLevel4 = ""
            tmpLevel5 = ""
            varParentId = tmpLevel1
        ElseIf Trim(RangeArray(curRow, 5)) <> "" Then
            varName = Trim(RangeArray(curRow, 5))
            varLevel = 3
            tmpLevel3 = Trim(RangeArray(curRow, 1))
            tmpLevel4 = ""
            tmpLevel5 = ""
            varParentId = tmpLevel2
        ElseIf Trim(RangeArray(curRow, 6)) <> "" Then
            varName = Trim(RangeArray(curRow, 6))
            tmpLevel4 = Trim(RangeArray(curRow, 1))
            varLevel = 4
            tmpLevel5 = ""
            If tmpLevel3 = "" Then
                varParentId = tmpLevel2
            Else
                varParentId = tmpLevel3
            End If
        Else
            'Nameの先頭に半角・全角スペースの存在を正規表現でチェック
            re.Pattern = "(^( |　))"
            re.Global = False
            If re.test(RangeArray(curRow, 7)) Then
                varName = Trim(RangeArray(curRow, 7))
                varLevel = 6
                varParentId = tmpLevel5
            Else
                varName = Trim(RangeArray(curRow, 7))
                varLevel = 5
                tmpLevel5 = Trim(RangeArray(curRow, 1))
                varParentId = tmpLevel4
            End If
        End If
        varRefCtg = Trim(RangeArray(curRow, 8))
        varFinancialCtg = Trim(RangeArray(curRow, 9))
        varPurposeCtg = Trim(RangeArray(curRow, 10))
        varUnit = Trim(RangeArray(curRow, 11))
        If IsNumeric(Trim(RangeArray(curRow, 12))) Then
            varProductW = Trim(RangeArray(curRow, 12))
        Else
            varProductW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 13))) Then
            varShipW = Trim(RangeArray(curRow, 13))
        Else
            varShipW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 14))) Then
            varInventoryW = Trim(RangeArray(curRow, 14))
        Else
            varInventoryW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 15))) Then
            varRationW = Trim(RangeArray(curRow, 15))
        Else
            varRationW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 16))) Then
            varReId = Trim(RangeArray(curRow, 16))
        Else
            varReId = 0
        End If
        varCountChildren = 0
        Add varId, varName, varRefCtg, varFinancialCtg, varPurposeCtg, varUnit, varProductW, varShipW, varInventoryW, varRationW, varLevel, varParentId, varReId, varCountChildren, varId
        If Trim(varParentId) <> "" Then
           cntChildren = tManage.colItems.AddCountChildrenByIndex(varParentId)
        End If
    Next curRow
    Set GetXLData = Me
    objXLBook.Close SaveChanges:=False
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    Set re = Nothing
    Application.ScreenUpdating = True
End Function

'キーを指定してclsItemを返す
Public Function GetItemByIndex(strKey As String) As clsItem
    On Error GoTo ErrRtn
    Set GetItemByIndex = Me.Item(strKey)
    Exit Function
ErrRtn:
    Set GetItemByIndex = Nothing
End Function

'キーを指定してclsItemを取得し、CountChildrenを加算する。
Public Function AddCountChildrenByIndex(strKey As String) As Integer
    Dim tmpItem As clsItem
    Set tmpItem = Me.GetItemByIndex(strKey)
    If Not tmpItem Is Nothing Then
        tmpItem.CountChildren = tmpItem.CountChildren + 1
    End If
    AddCountChildrenByIndex = tmpItem.CountChildren
End Function

'メンバー全消去
Public Function ClearAllMember() As Boolean
    Dim i As Long
    ClearAllMember = False
    For i = Me.Count To 1 Step -1
        Me.Remove i
    Next i
    ClearAllMember = True
End Function

'初期処理
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

'クラス削除時処理
Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

[colReMsts]

Option Explicit
Private mCol As Collection
Const INITROW = 2       '空白を除いたデータの開始行
Const INITCLM = 1       '空白を除いたデータの開始列

'メンバー追加
Public Function Add(ReId As Integer, Name As String, ReVal As Integer, _
        ProductW As Currency, ShipW As Currency, InventoryW As Currency, RationW As Currency, _
        Optional sKey As String) As clsReMst
    Dim objNewMember As clsReMst
    Set objNewMember = New clsReMst
    With objNewMember
        .ReId = ReId
        .Name = Name
        .ReVal = ReVal
        .ProductW = ProductW
        .ShipW = ShipW
        .InventoryW = InventoryW
        .RationW = RationW
    End With
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

'キーまたは番号でメンバー取得
Public Property Get Item(vntIndexKey As Variant) As clsReMst
  Set Item = mCol(vntIndexKey)
End Property

'メンバー数を取得
Public Property Get Count() As Long
    Count = mCol.Count
End Property

'メンバーを削除
Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'メンバー列挙（For Each に必要)
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

'エクセルを開いて対象シートを読み、行の情報からクラスを作成し、コレクションに追加
Public Function GetXLData() As colReMsts
    Application.ScreenUpdating = False
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    
    Dim RangeArray
    Dim strRange As String
    
    Dim curRow As Integer
    Dim EndRow As Integer
    
    Dim varReId As Integer
    Dim varName As String
    Dim varReVal As Integer
    Dim varProductW As Currency            'ウエイト生産
    Dim varShipW As Currency               'ウエイト出荷
    Dim varInventoryW As Currency          'ウエイト在庫
    Dim varRationW As Currency             'ウエイト在庫率
    
    Set GetXLData = Nothing
    ClearAllMember
    
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(tManage.ReMstFile, False, True)
    
     With objXLBook.Worksheets(CInt(tManage.ReMstSheet))
        strRange = .Cells(INITROW, INITCLM).CurrentRegion.Address
        EndRow = CLng(Mid(strRange, 9))
        RangeArray = .Range(strRange).Value
    End With
    
    For curRow = INITROW To EndRow
        varReId = Trim(RangeArray(curRow, 1))
        varName = Trim(RangeArray(curRow, 2))
        varReVal = Trim(RangeArray(curRow, 3))
        varProductW = 0
        varShipW = 0
        varInventoryW = 0
        varRationW = 0
        Add varReId, varName, varReVal, varProductW, varShipW, varInventoryW, varRationW, CStr(varReId)
    Next curRow
    Set GetXLData = Me
    objXLBook.Close SaveChanges:=False
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    Application.ScreenUpdating = True
End Function

'メンバー全消去
Public Function ClearAllMember() As Boolean
    Dim i As Long
    ClearAllMember = False
    For i = Me.Count To 1 Step -1
        Me.Remove i
    Next i
    ClearAllMember = True
End Function

'キーを指定してclsReMstを返す
Public Function GetReMstByIndex(strKey As String) As clsReMst
    On Error GoTo ErrRtn
    Set GetReMstByIndex = Me(strKey)
    Exit Function
ErrRtn:
    Set GetReMstByIndex = Nothing
End Function

'初期処理
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

'クラス削除時処理
Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

[colIndMsts]

Option Explicit
Private mCol As Collection

Const INITROW = 2       '空白を除いたデータの開始行
Const INITCLM = 1       '空白を除いたデータの開始列

'メンバー追加
Public Function Add(SrgId As Integer, IndId As Integer, IndName As String, ItemFrom As String, ItemTo As String, _
        ProductW As Currency, ShipW As Currency, InventoryW As Currency, RationW As Currency, ParentId As Integer, Haschild As Boolean, _
        ProductD As Currency, ShipD As Currency, InventoryD As Currency, RationD As Currency, _
        Optional sKey As String) As clsIndMst
    Dim objNewMember As clsIndMst
    Set objNewMember = New clsIndMst
    With objNewMember
        .SrgId = SrgId
        .IndId = IndId
        .IndName = IndName
        .ItemFrom = ItemFrom
        .ItemTo = ItemTo
        .ProductW = ProductW
        .ShipW = ShipW
        .InventoryW = InventoryW
        .RationW = RationW
        .ParentId = ParentId
        .Haschild = Haschild
        .ProductD = ProductD
        .ShipD = ShipD
        .InventoryD = InventoryD
        .RationD = RationD
    End With
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

'キーまたは番号でメンバー取得
Public Property Get Item(vntIndexKey As Variant) As clsIndMst
  Set Item = mCol(vntIndexKey)
End Property

'メンバー数を取得
Public Property Get Count() As Long
    Count = mCol.Count
End Property

'メンバーを削除
Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'メンバー列挙（For Each に必要)
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

'エクセルを開いて対象シートを読み、行の情報からクラスを作成し、コレクションに追加
Public Function GetXLData() As colIndMsts
    Application.ScreenUpdating = False
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    
    Dim RangeArray
    Dim strRange As String
    
    Dim curRow As Integer
    Dim EndRow As Integer
    
    Dim varSrgId As Integer
    Dim varIndId As Integer
    Dim varIndName As String
    Dim varItemFrom As String
    Dim varItemTo As String
    Dim varProductW As Currency            'ウエイト生産
    Dim varShipW As Currency               'ウエイト出荷
    Dim varInventoryW As Currency          'ウエイト在庫
    Dim varRationW As Currency             'ウエイト在庫率
    Dim varParentId As Integer
    Dim varHasChild As Boolean
    Dim varProductD As Currency            'Data生産
    Dim varShipD As Currency               'Data出荷
    Dim varInventoryD As Currency          'Data在庫
    Dim varRationD As Currency             'Data在庫率
    
    Dim targetCode As String
    
    Dim re As Object
    Dim existSpace As Boolean
    Dim tmpParentId As Integer
    
    Set GetXLData = Nothing
    
    '正規表現RegExpのバインディング
    Set re = CreateObject("VBScript.RegExp")
    '
    ClearAllMember
    
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(tManage.IndMstFile, False, True)
    
     With objXLBook.Worksheets(CInt(tManage.IndMstSheet))
        strRange = .Cells(INITROW, INITCLM).CurrentRegion.Address
        EndRow = CLng(Mid(strRange, 9))
        RangeArray = .Range(strRange).Value
    End With
    
    For curRow = INITROW To EndRow
        varSrgId = curRow - 1
        varIndId = Trim(RangeArray(curRow, 1))
        re.Pattern = "(^( |　))"
        re.Global = False
        existSpace = re.test(RangeArray(curRow, 2))
        varIndName = Trim(RangeArray(curRow, 2))
        If existSpace Then
            varParentId = tmpParentId
        Else
            varParentId = 0
            tmpParentId = varSrgId
        End If
        re.Pattern = "[^0-9]"
        re.Global = False
        targetCode = re.Replace(Trim(RangeArray(curRow, 3)), "")
        If Len(targetCode) > 8 Then
            varItemFrom = Left(targetCode, 8)
            varItemTo = Right(targetCode, 8)
        Else
            varItemFrom = Left(targetCode, 8)
            varItemTo = Left(targetCode, 8)
        End If
        varHasChild = False
        varProductW = Trim(RangeArray(curRow, 4))
        varShipW = Trim(RangeArray(curRow, 5))
        varInventoryW = Trim(RangeArray(curRow, 6))
        varRationW = Trim(RangeArray(curRow, 7))
        Add varSrgId, varIndId, varIndName, varItemFrom, varItemTo, varProductW, varShipW, varInventoryW, varRationW, varParentId, varHasChild, 0, 0, 0, 0, CStr(varSrgId)
        '
        If varParentId <> 0 Then
            If Not tManage.colIndMsts(varParentId).Haschild Then
                tManage.colIndMsts(varParentId).Haschild = True
            End If
        End If
    Next curRow
    Set GetXLData = Me
    objXLBook.Close SaveChanges:=False
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    Set re = Nothing
    Application.ScreenUpdating = True
End Function

'メンバー全消去
Public Function ClearAllMember() As Boolean
    Dim i As Long
    ClearAllMember = False
    For i = Me.Count To 1 Step -1
        Me.Remove i
    Next i
    ClearAllMember = True
End Function

'キーを指定してclsIndMstを返す
Public Function GetIndMstByIndex(strKey As String) As clsIndMst
    On Error GoTo ErrRtn
    Set GetIndMstByIndex = Me(strKey)
    Exit Function
ErrRtn:
    Set GetIndMstByIndex = Nothing
End Function

'初期処理
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

'クラス削除時処理
Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

[colCItems]

Option Explicit
Private mCol As Collection

Const INITROW = 2       '空白を除いたデータの開始行
Const INITCLM = 1       '空白を除いたデータの開始列
Const SPLIT_STR = "/+/" '返り値を分割する区切り文字

'メンバー追加
Public Function Add(Id As String, Name As String, ProductW As Currency, ShipW As Currency, InventoryW As Currency, RationW As Currency, _
                ParentId As Integer, ParentName As String, ReId As Integer, _
                ProductD As Currency, ShipD As Currency, InventoryD As Currency, RationD As Currency, Optional sKey As String) As clsCItem
    Dim objNewMember As clsCItem
    Set objNewMember = New clsCItem
    With objNewMember
        .Id = Id
        .Name = Name
        .ProductW = ProductW
        .ShipW = ShipW
        .InventoryW = InventoryW
        .RationW = RationW
        .ParentId = ParentId
        .ParentName = ParentName
        .ReId = ReId
        .ProductD = ProductD
        .ShipD = ShipD
        .InventoryD = InventoryD
        .RationD = RationD
    End With
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

'キーまたは番号でメンバー取得
Public Property Get Item(vntIndexKey As Variant) As clsCItem
  Set Item = mCol(vntIndexKey)
End Property

'メンバー数を取得
Public Property Get Count() As Long
    Count = mCol.Count
End Property

'メンバーを削除
Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'メンバー列挙（For Each に必要)
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

'エクセルを開いて対象シートを読み、行の情報からクラスを作成し、コレクションに追加
Public Function GetXLData() As colCItems
    Application.ScreenUpdating = False
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    
    Dim RangeArray                         'データを配列に取得
    Dim strRange As String                 'A1形式のレンジ取得文字列
    
    Dim curRow As Integer
    Dim EndRow As Integer
    
    Dim tmpResult As Variant
         
    Dim varId As String                    '番号
    Dim varName As String                  '名称
    Dim varRefCtg As String                '参考分類
    Dim varProductW As Currency            'ウエイト生産
    Dim varShipW As Currency               'ウエイト出荷
    Dim varInventoryW As Currency          'ウエイト在庫
    Dim varRationW As Currency             'ウエイト在庫率
    Dim varParentId As Integer             '階層親番号
    Dim varParentName As String            '階層親名称
    Dim varReId As Integer                 '対象再掲項目ID値合計
    Dim varProductD As Currency            'Data生産
    Dim varShipD As Currency               'Data出荷
    Dim varInventoryD As Currency          'Data在庫
    Dim varRationD As Currency             'Data在庫率
    '
    Set GetXLData = Nothing
    '
    ClearAllMember
    '
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(tManage.CItemFile, True, True)
    
    With objXLBook.Worksheets(CInt(tManage.CItemSheet))
        strRange = .Cells(INITROW, INITCLM).CurrentRegion.Address
        EndRow = CLng(Mid(strRange, 9))
        '対象のRange取得
        RangeArray = .Range(strRange).Value
    End With
    '対象のRangeをループ
    For curRow = INITROW To EndRow
        'IDが見かけ上文字だが、数値なので8桁文字に統一
        varId = Format(Trim(RangeArray(curRow, 1)), "00000000")
        varName = Trim(RangeArray(curRow, 3))
        If IsNumeric(Trim(RangeArray(curRow, 4))) Then
            varProductW = Trim(RangeArray(curRow, 4))
        Else
            varProductW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 5))) Then
            varShipW = Trim(RangeArray(curRow, 5))
        Else
            varShipW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 6))) Then
            varInventoryW = Trim(RangeArray(curRow, 6))
        Else
            varInventoryW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 7))) Then
            varRationW = Trim(RangeArray(curRow, 7))
        Else
            varRationW = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 8))) Then
            varReId = Trim(RangeArray(curRow, 8))
        Else
            varReId = 0
        End If
        '分割文字を利用して配列に変換
        tmpResult = Split(GetParentIdByID(varId), SPLIT_STR)
        varParentId = tmpResult(0)
        varParentName = tmpResult(1)
        Add varId, varName, varProductW, varShipW, varInventoryW, varRationW, varParentId, varParentName, varReId, 0, 0, 0, 0, varId
    Next curRow
    Set GetXLData = Me
    objXLBook.Close SaveChanges:=False
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    Application.ScreenUpdating = True
End Function


'キーを指定してclsItemを返す
Public Function GetCItemByIndex(strKey As String) As clsCItem
   On Error GoTo ErrRtn
    Set GetCItemByIndex = Me.Item(strKey)
    Exit Function
ErrRtn:
    Set GetCItemByIndex = Nothing
End Function
'
'メンバー全消去
Public Function ClearAllMember() As Boolean
    Dim i As Long
    ClearAllMember = False
    For i = Me.Count To 1 Step -1
        Me.Remove i
    Next i
    ClearAllMember = True
End Function

'キーを指定してcolIndMstsから所属するsrgId&IndNameを取得。配列で返すべきだが、取得先で配列に。
Public Function GetParentIdByID(strKey As String) As String
    Dim tIndMst As clsIndMst
    GetParentIdByID = ""
    For Each tIndMst In tManage.colIndMsts
        If Not tIndMst.Haschild Then
            If strKey >= tIndMst.ItemFrom And strKey <= tIndMst.ItemTo Then
                GetParentIdByID = tIndMst.SrgId & SPLIT_STR & tIndMst.IndName
                Exit For
            End If
        End If
    Next
End Function

'初期処理
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

'クラス削除時処理
Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

[colIIPDatas]

Option Explicit
Private mCol As Collection

Const INITROW = 2       '空白を除いたデータの開始行
Const INITCLM = 1       '空白を除いたデータの開始列
Const SPLIT_STR = "/+/" '返り値を分割する区切り文字

'メンバー追加
Public Function Add(Id As String, Name As String, ProductD As Currency, ShipD As Currency, InventoryD As Currency, RationD As Currency, _
                ParentId As Integer, ParentName As String, Optional sKey As String) As clsIIPData
    Dim objNewMember As clsIIPData
    Set objNewMember = New clsIIPData
    With objNewMember
        .Id = Id
        .Name = Name
        .ProductD = ProductD
        .ShipD = ShipD
        .InventoryD = InventoryD
        .RationD = RationD
        .ParentId = ParentId
        .ParentName = ParentName
    End With
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

'キーまたは番号でメンバー取得
Public Property Get Item(vntIndexKey As Variant) As clsIIPData
  Set Item = mCol(vntIndexKey)
End Property

'メンバー数を取得
Public Property Get Count() As Long
    Count = mCol.Count
End Property

'メンバーを削除
Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'メンバー列挙（For Each に必要)
Public Property Get NewEnum() As IUnknown
    Set NewEnum = mCol.[_NewEnum]
End Property

'エクセルを開いて対象シートを読み、行の情報からクラスを作成し、コレクションに追加
Public Function GetXLData() As colIIPDatas
    Application.ScreenUpdating = False
    Dim objXLAp As New Excel.Application
    Dim objXLBook As Excel.Workbook
    
    Dim RangeArray                         'データを配列に取得
    Dim strRange As String                 'A1形式のレンジ取得文字列
    
    Dim curRow As Integer
    Dim EndRow As Integer
    
    Dim tmpResult As Variant
         
    Dim varId As String                    '番号
    Dim varName As String                  '名称
    Dim varProductD As Currency            'Data生産
    Dim varShipD As Currency               'Data出荷
    Dim varInventoryD As Currency          'Data在庫
    Dim varRationD As Currency             'Data在庫率
    Dim varParentId As Integer             '階層親番号
    Dim varParentName As String            '階層親名称
    
    Set GetXLData = Nothing
    '
    ClearAllMember
    '
    objXLAp.ScreenUpdating = False
    objXLAp.Visible = False
    Set objXLBook = objXLAp.Workbooks.Open(tManage.IIPDataFile, True, True)
    
    With objXLBook.Worksheets(CInt(tManage.IIPDataSheet))
        strRange = .Cells(INITROW, INITCLM).CurrentRegion.Address
        EndRow = CLng(Mid(strRange, 9))
        '対象のRange取得
        RangeArray = .Range(strRange).Value
    End With
    '対象のRangeをループ
    For curRow = INITROW To EndRow
        'IDが見かけ上文字だが、数値なので8桁文字に統一
        varId = Format(Trim(RangeArray(curRow, 1)), "00000000")
        varName = Trim(RangeArray(curRow, 2))
        If IsNumeric(Trim(RangeArray(curRow, 3))) Then
            varProductD = Trim(RangeArray(curRow, 3))
        Else
            varProductD = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 4))) Then
            varShipD = Trim(RangeArray(curRow, 4))
        Else
            varShipD = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 5))) Then
            varInventoryD = Trim(RangeArray(curRow, 5))
        Else
            varInventoryD = 0
        End If
        If IsNumeric(Trim(RangeArray(curRow, 6))) Then
            varRationD = Trim(RangeArray(curRow, 6))
        Else
            varRationD = 0
        End If
        tmpResult = Split(GetParentIdByID(varId), SPLIT_STR)
        varParentId = tmpResult(0)
        varParentName = tmpResult(1)
        Add varId, varName, varProductD, varShipD, varInventoryD, varRationD, varParentId, varParentName, varId
    Next curRow
    Set GetXLData = Me
    objXLBook.Close SaveChanges:=False
    Set objXLBook = Nothing
    objXLAp.Quit
    Set objXLAp = Nothing
    Application.ScreenUpdating = True
End Function

'キーを指定してclsIIPDataを返す
Public Function GetIIPDataByIndex(strKey As String) As clsIIPData
    On Error GoTo ErrRtn
    Set GetIIPDataByIndex = Me.Item(strKey)
    Exit Function
ErrRtn:
    Set GetCItemByIndex = Nothing
End Function
'メンバー全消去
Public Function ClearAllMember() As Boolean
    Dim i As Long
    ClearAllMember = False
    For i = Me.Count To 1 Step -1
        Me.Remove i
    Next i
    ClearAllMember = True
End Function

'キーを指定してcolIndMstsから所属するsrgId&IndNameを取得。
Public Function GetParentIdByID(strKey As String) As String
    Dim tIndMst As clsIndMst
    GetParentIdByID = ""
    For Each tIndMst In tManage.colIndMsts
        If Not tIndMst.Haschild Then
            If strKey >= tIndMst.ItemFrom And strKey <= tIndMst.ItemTo Then
                GetParentIdByID = tIndMst.SrgId & SPLIT_STR & tIndMst.IndName
                Exit For
            End If
        End If
    Next
End Function

'初期処理
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

'クラス削除時処理
Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

コレクションの中から検索抽出して新たな同じクラスのコレクションを作るサンプル
colPartKotes

Public Function GetPartKotesByPart(strPartID As String) As colPartKotes
    Dim strKey As String
    Dim MaxNo As Integer
    Dim ExistFlg As Boolean
    Dim tPartkote As clsPartKote
    Dim tPartKotes As colPartKotes
    Dim KoteCnt As Integer
    '
    ExistFlg = True
    '
    On Error GoTo ErrRtn
    '
    Set tPartKotes = New colPartKotes
    '
    strKey = strPartID & "_1"
    Set tPartkote = Me(strKey)
    If ExistFlg Then
        MaxNo = tPartkote.MaxNo
        Set tPartkote = Nothing
        For KoteCnt = 1 To MaxNo
            strKey = strPartID & "_" & CStr(KoteCnt)
            Set tPartkote = tManage.colPartKotes.Item(strKey)
            If ExistFlg Then
                With tPartkote
                    tPartKotes.Add .PartID, .PartName, .PKMachineCD, .PKKote, .PKDay, .TeamCD, .SubID, .MaxNo, .PartID & "_" & CStr(.SubID)
                End With
            Else
                ExistFlg = True
            End If
        Next KoteCnt
        Set GetPartKotesByPart = tPartKotes
        Set tPartkote = Nothing
        Set tPartKotes = Nothing
    Else
        Set GetPartKotesByPart = Nothing
    End If
    Exit Function
ErrRtn:
    ExistFlg = False
    Resume Next
End Function

'おまけ
'コレクションや配列で受け取る代わりに文字列を区切り文字で渡して、受け取った側で配列に分解
Sub test()
  Dim tmpArray
  Dim i As Integer
  tmpArray = Split(Cells(2, 2).Value, ",")
  MsgBox UBound(tmpArray)
  If UBound(tmpArray) > 0 Then
    For i = UBound(tmpArray) To 1 Step -1
      MsgBox tmpArray(i) & ": " & tmpArray(i - 1)
    Next i
  End If
End Sub