Excel VBA 部品表展開

Option Explicit
Option Base 1

Dim 読み込み行 As Integer  'BOMデータの読み込み行数

Dim BOM構成()
Dim BomText As String
Dim 行データ As String
Dim 追加シート名 As String
Dim 処理行 As Integer
Dim 親品目番号 As String
Dim 検索行 As Integer

'**************全体フロー************
省略
'*****BOMテキストデータを読み込む****
省略
'*★★ローレベルコードを設定する★★*
省略
'*入力データの、ループ(自分の子孫に自分が出現)をチェック*
省略

'******入力データの並び替え**********

Private Sub 並べ替え()

    追加シート名 = "ソート作業"

    '前回シートが残っていれば、削除
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets(追加シート名).Delete
    Application.DisplayAlerts = True

    '新規にシート追加

    ThisWorkbook.Worksheets.Add
    ActiveSheet.Name = 追加シート名

    ThisWorkbook.Worksheets(追加シート名).Range("A1").Resize(読み込み行, 5).Value = BOM構成

    Range("B1").Select

    Worksheets(追加シート名).Range("B1").CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, _
    Key2:=Range("C1"), Order2:=xlAscending, Key3:=Range("D1"), Order3:=xlAscending, _
    Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
    xlTopToBottom, SortMethod:=xlPinYin

    ReDim BOM構成(読み込み行, 5)

    BOM構成 = ThisWorkbook.Worksheets(追加シート名).Range("A1").Resize(読み込み行, 5).Value

End Sub

'***********配列の出力とソート*****************
省略

Option Explicit
Option Base 1

   Public 開始日時 As Variant
   Public 終了日時 As Variant
   Dim 前レベル終了日時 As Variant

   Public 検索行 As Long
   Dim 検索開始行 As Long
   Public ファイルシステムオブジェクト As Object           ' FileSystemObject
   Public レベル As Integer
   Public 部品表構成入力ファイル名 As String
   Public 部品表構成入力ファイル名指定 As String
   Public 部品表構成入力テキストストリームオブジェクト As Object     ' TextStream
   Dim 出力テキストストリームオブジェクト As Object     ' TextStream
   Dim 出力テキストストリームオブジェクト2 As Object     ' TextStream
   Dim 出力テキストストリームオブジェクト3 As Object     ' TextStream
   Dim 部品表構成入力テキストストリームオブジェクト孫 As Object     ' TextStream
   Dim LLC付き親品番リスト名 As String

   Dim 現在のパス As String

   Public 入力行 As String
   Public 出力行 As String
   Public 親品番 As String
   Public 前親品番 As String
   Dim 親品番退避 As String
   Public 子品番 As String

   Dim 処理行 As Long
   Dim 数量 As Integer
   Dim 数量文字 As String
   Dim 親品番件数 As Long
   Dim シングル構成件数 As Long  'BOMデータの読み込み行数
   Dim LLC As Integer

   Dim 検索文字列 As String
   Dim 読み込み行文字数 As Integer
   Dim 検索桁前 As Integer
   Dim 検索桁後 As Integer
   Dim 検索桁後ろから2つめ As Integer

   Dim 一時配列() As String 'ソート順位が狂わないように固定長にする。親品番30、子品番30、親当たり数量5
   Dim 一時配列temp() As String  '子品番30、親品番30、親当たり数量5、親LLC3
   Dim 処理内容 As String
   Dim 区切り方式 As String
   Dim 集約展開構成件数 As Long
   Dim 親品番LLC配列(1000000, 2) As Variant '親品番、LLC

   Dim 親品番索引 As Object        'Scripting.Dictionary オブジェクト
   Dim シングル構成親品番索引 As Object        'Scripting.Dictionary オブジェクト
   Dim ループ構成(1000, 4) As Variant
   Dim ループ件数 As Integer
   Dim ループ構成リスト名 As String
   Dim 下位LLCでの出力件数 As Long
   Dim 最大LLC As Integer
   Dim 状況表示 As Boolean
   Dim ワーク行数 As Integer
   Dim 最終行 As Integer
   Dim 行 As Integer
   Dim 親品番別集約展開ファイル名 As String
   Dim 品番単位の最大集約構成行数 As Integer
   Dim 子品番ファイル名 As String

   Dim 子品番と構成数の配列() As Variant '子品番固定長、構成数量
   Dim 子品番索引 As Object        'Scripting.Dictionary オブジェクト
   Dim 子品番件数 As Long

'**************全体フロー************
Sub 全体フロー()

    開始日時 = Now()

   ThisWorkbook.Worksheets("マクロの仕様").Activate
    部品表構成入力ファイル名指定 = Range("D1").value
    状況表示 = Range("H3").value
    現在のパス = ThisWorkbook.Path
    ループ件数 = 0

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Call 入力件数をカウント

   '★ LLC を算出 ★
   Call ファイルを読み込む

      処理内容 = "部品表構成ファイルを並び替え"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call クイックソート(一時配列, 1, シングル構成件数)

      処理内容 = "親品番一覧と子親配列を作成"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call 親品番一覧と子親配列を作成

      処理内容 = "子親数量配列を並び替え"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call クイックソート(一時配列temp, 1, シングル構成件数)

      処理内容 = "LLC設定"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call LLC設定

   '★ 集約展開 ★
   Call ファイルを読み込む   'LLC 設定前に、読み込んだシングル構成を廃棄しているので、再読み込みする

      処理内容 = "部品表構成ファイルを並び替え"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call クイックソート(一時配列, 1, シングル構成件数)

      処理内容 = "集約展開"
      Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call 集約展開

   '★ 子品番最大数リストを出力 ★
   Call 子品番最大数リストを出力

   処理内容 = "個別ファイル削除"
   Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call フォルダを削除


終了処理:

   Set ファイルシステムオブジェクト = Nothing

   ThisWorkbook.Worksheets("マクロの仕様").Activate

   終了日時 = Now()

   If ループ件数 = 0 Then
      MsgBox Chr(13) & "処理時間は、" & Format(終了日時 - 開始日時, "h時間nn分ss秒") & " でした。" & vbNewLine _
      & "入力したシングル構成件数は " & Format(シングル構成件数, "#,##0") & " でした。" & vbNewLine _
      & "集約展開構成件数 " & Format(集約展開構成件数, "#,##0") & " を出力しました。", vbOKOnly
   Else
      MsgBox Chr(13) & "処理時間は、" & Format(終了日時 - 開始日時, "h時間nn分ss秒") & " でした。" & vbNewLine _
      & "入力したシングル構成件数は " & Format(シングル構成件数, "#,##0") & " でした。" & vbNewLine _
      & "集約展開構成件数 " & Format(集約展開構成件数, "#,##0") & " を出力しました。" & vbNewLine _
      & "構成にループがありました。ループ構成リストを出力しました。", vbOKOnly
   End If
   Application.StatusBar = False
End Sub


'*************BOMデータから親品番の顔ぶれを配列に読み込む***************************
'*************また、子→親の順にした配列を作成する***************************

Private Sub 親品番一覧と子親配列を作成()

   ReDim 一時配列temp(シングル構成件数) As String
   'Loop 前の、変数初期化
   親品番件数 = 0

   For 処理行 = 1 To シングル構成件数

      入力行 = 一時配列(処理行)

      親品番 = Left(入力行, 30)

      If 処理行 > 1 And 親品番 <> 前親品番 Then
            親品番退避 = 親品番
            親品番 = 前親品番

            親品番件数 = 親品番件数 + 1

            親品番LLC配列(親品番件数, 1) = RTrim(前親品番)

            親品番 = 親品番退避
      End If

      子品番 = Mid(入力行, 31, 30)
      数量文字 = Right(入力行, 5)

      一時配列temp(処理行) = 子品番 & 親品番 & 数量文字 & Space(3)

      前親品番 = 親品番

   Next 処理行

   親品番件数 = 親品番件数 + 1
   親品番LLC配列(親品番件数, 1) = RTrim(親品番)

'Stop

   Erase 一時配列    'LLC の計算には、シングル逆展開しか使わないので、メモリ消費を削減する
   ReDim 一時配列(1) As String 'これでメモリ消費が抑えられる？

End Sub



'******************★★ローレベルコードを設定して結果を txt 出力する★★********************
'******************★★ LLC が設定できない品番は、ループを含んでいる★★********************

Private Sub LLC設定()

    Dim 未設定行数 As Long
    Dim LLC設定品番数 As Long
    Dim 品番存在 As String

   '★親品番索引を作成★
   Set 親品番索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義

   For 処理行 = 1 To 親品番件数
      親品番 = 親品番LLC配列(処理行, 1)
      親品番索引(親品番) = 処理行
   Next 処理行

   未設定行数 = 親品番件数
   LLC設定品番数 = 0

   For LLC = 1 To 100 'LLCは、一般に20程度。完了した時点で、ループを抜ける。

      検索開始行 = 1

      '*****************************************************************:

      For 処理行 = 1 To 親品番件数

         品番存在 = ""
'Stop
         If 親品番LLC配列(処理行, 2) = "" Then ' LLC未設定を対象

            親品番 = 親品番LLC配列(処理行, 1)

            For 検索行 = 検索開始行 To シングル構成件数
               If Trim(Right(一時配列temp(検索行), 3)) = "" Then ' LLC未設定を対象

                  子品番 = RTrim(Left(一時配列temp(検索行), 30))

                  If 親品番 < 子品番 Then
                     検索開始行 = 検索行
                     Exit For
                  ElseIf 親品番 = 子品番 Then
                     品番存在 = "存在"
                  End If

               End If

            Next 検索行

            If 品番存在 = "" Then '構成に存在しない場合にLLCを設定

               親品番LLC配列(処理行, 2) = LLC
               最大LLC = LLC
               LLC設定品番数 = LLC設定品番数 + 1
               未設定行数 = 未設定行数 - 1
               If 未設定行数 <= 0 Then Exit For '全ての親品目にLLCが設定できたら、ループ を抜ける

            End If

         End If
      Next 処理行

      '*****************************************************************

      If LLC設定品番数 = 0 Then Exit For
      If 未設定行数 = 0 Then Exit For

      '親品番に設定したLLCを、構成の方にも付ける
      For 処理行 = 1 To シングル構成件数
         If Trim(Right(一時配列temp(処理行), 3)) = "" Then ' LLC未設定を対象

            親品番 = RTrim(Mid(一時配列temp(処理行), 31, 30))

            If 親品番LLC配列(親品番索引(親品番), 2) <> "" Then   ' LLC設定を対象
               Mid(一時配列temp(処理行), 66, 3) = Right(Space(3) & 親品番LLC配列(親品番索引(親品番), 2), 3)
            End If

         End If
      Next 処理行

   Next LLC

   '★★結果を txt 出力★★
   LLC付き親品番リスト名 = 現在のパス & "\結果"
   If ファイルシステムオブジェクト.FolderExists(LLC付き親品番リスト名) = False Then
      ファイルシステムオブジェクト.CreateFolder (LLC付き親品番リスト名)
   End If
   LLC付き親品番リスト名 = 現在のパス & "\結果\LLC付き親品番リスト.txt"
   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(LLC付き親品番リスト名)

   For 処理行 = 1 To 親品番件数

      出力行 = 親品番LLC配列(処理行, 2) & "," & 親品番LLC配列(処理行, 1)
      出力テキストストリームオブジェクト.WriteLine 出力行     'LLCと決定親品番を書き出す

   Next 処理行
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing

   'ループ構成を配列に格納

   For 処理行 = 1 To シングル構成件数
      If Trim(Right(一時配列temp(処理行), 3)) = "" Then
         ループ件数 = ループ件数 + 1
         ループ構成(ループ件数, 1) = RTrim(Mid(一時配列temp(処理行), 31, 30)) '親品番
         ループ構成(ループ件数, 2) = RTrim(Left(一時配列temp(処理行), 30)) '子品番
         ループ構成(ループ件数, 3) = Trim(Mid(一時配列temp(処理行), 61, 5)) '数量
      End If
   Next 処理行

   If ループ件数 > 0 Then
      Call ループチェック
   End If

   Erase 一時配列temp
   ReDim 一時配列temp(1) As String

   '★親品番索引を解放★
   Set 親品番索引 = Nothing

End Sub



Private Sub ファイルを読み込む()

   ReDim 一時配列(シングル構成件数) As String
   処理内容 = "ファイルを読み込む"

   '***********ファイルの読み込んで固定長にして配列に格納する************

   部品表構成入力ファイル名 = 現在のパス & "\" & 部品表構成入力ファイル名指定
   '変数初期化
   検索文字列 = Chr(34) & "," & Chr(34)
   区切り方式 = ""

   ' 指定ファイルをOPEN(入力モード)
   Set 部品表構成入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(部品表構成入力ファイル名, 1)

   シングル構成件数 = 0

   Do Until 部品表構成入力テキストストリームオブジェクト.AtEndOfStream

      入力行 = 部品表構成入力テキストストリームオブジェクト.ReadLine
      入力行 = Trim(入力行)
      If 入力行 = "" Then GoTo 次の行へ
      シングル構成件数 = シングル構成件数 + 1

      If シングル構成件数 = 1 Then 'TAB 区切りか、CSVか判定
         If InStr(入力行, vbTab) = 0 Then
            区切り方式 = "CSV"
         End If
      End If

      If (シングル構成件数 Mod 10000) = 0 Then
         Application.StatusBar = "☆" & Format(シングル構成件数, "#,##0") & " 行目を読込み☆ " & 処理内容
      ElseIf (シングル構成件数 Mod 5000) = 0 Then
         Application.StatusBar = "★" & Format(シングル構成件数, "#,##0") & " 行目を読込み★ " & 処理内容
      End If


      If 区切り方式 = "CSV" Then

         '","区切りの場合(この例は、特殊の形式で、行頭に , が付いている)

         ',"21W6243930","21W624393003","2"
         ',"21W9734141","0158353320","1"
         ',"21WY143J70","21WY143J70K1","1"

         読み込み行文字数 = Len(入力行)
         検索桁前 = InStr(入力行, 検索文字列)
         検索桁後 = InStrRev(入力行, 検索文字列)

         親品番 = Trim(Mid(入力行, 3, 検索桁前 - 3))
         子品番 = Trim(Mid(入力行, 検索桁前 + 3, 検索桁後 - 検索桁前 - 3))
         数量 = Val(Mid(入力行, 検索桁後 + 3, 読み込み行文字数 - 検索桁後 - 3))
'Stop
      Else 'TAB区切りの場合

         読み込み行文字数 = Len(入力行)
         検索桁前 = InStr(入力行, vbTab)
         検索桁後 = InStrRev(入力行, vbTab)
         検索桁後ろから2つめ = InStrRev(入力行, vbTab, 検索桁後 - 1, vbTextCompare)

         親品番 = Trim(Left(入力行, 検索桁前 - 1))
         子品番 = Trim(Mid(入力行, 検索桁後ろから2つめ + 1, 検索桁後 - 検索桁後ろから2つめ - 1))
         数量 = Val(Right(入力行, 読み込み行文字数 - 検索桁後))

      End If

         出力行 = Left(親品番 & Space(30), 30) & Left(子品番 & Space(30), 30) & Right(Space(5) & CStr(数量), 5)
         一時配列(シングル構成件数) = 出力行 '読み込んだファイルを、固定長にして配列に格納
次の行へ:
   Loop

   ' 指定ファイルをClose(入力モード)
   部品表構成入力テキストストリームオブジェクト.Close
   Set 部品表構成入力テキストストリームオブジェクト = Nothing

End Sub



'**************入力データに、ループ(自分の子孫に自分が出現)をチェックする*************
Private Sub ループチェック()
   Dim 処理行親 As Integer
   Dim 処理行子 As Integer

   For 処理行親 = 1 To ループ件数
      For 処理行子 = 1 To ループ件数
         If ループ構成(処理行親, 1) = ループ構成(処理行子, 2) Then  '親子で同一品番有り
            ループ構成(処理行子, 4) = ループ構成(処理行子, 2) & " は、親側にも有り"
        End If
      Next 処理行子
   Next 処理行親

   '★★結果を txt 出力★★

   ループ構成リスト名 = 現在のパス & "\結果\ループ構成リスト.txt"
   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(ループ構成リスト名)

   For 処理行 = 1 To ループ件数

      出力行 = ループ構成(処理行, 1) & vbTab & ループ構成(処理行, 2) & vbTab _
      & ループ構成(処理行, 3) & vbTab & ループ構成(処理行, 4)
      出力テキストストリームオブジェクト.WriteLine 出力行     'ループ構成をコメント付きで書き出す

   Next 処理行
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing

End Sub


Private Sub 入力件数をカウント()

   処理内容 = "入力件数をカウント"

   '***********配列のサイズを決めるため、入力ファイルの行数をカウントする************

   部品表構成入力ファイル名 = 現在のパス & "\" & 部品表構成入力ファイル名指定

   ' 指定ファイルをOPEN(入力モード)
   Set 部品表構成入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(部品表構成入力ファイル名, 1)

   シングル構成件数 = 0

   Do Until 部品表構成入力テキストストリームオブジェクト.AtEndOfStream

      入力行 = 部品表構成入力テキストストリームオブジェクト.ReadLine
      シングル構成件数 = シングル構成件数 + 1

      If (シングル構成件数 Mod 10000) = 0 Then
         Application.StatusBar = "☆" & Format(シングル構成件数, "#,##0") & " 行目を読込み☆ " & 処理内容
      ElseIf (シングル構成件数 Mod 5000) = 0 Then
         Application.StatusBar = "★" & Format(シングル構成件数, "#,##0") & " 行目を読込み★ " & 処理内容
      End If

   Loop

   ' 指定ファイルをClose(入力モード)
   部品表構成入力テキストストリームオブジェクト.Close
   Set 部品表構成入力テキストストリームオブジェクト = Nothing

End Sub

'******************★★シングル逆展開出力★★*************************
Private Sub シングル逆展開出力()

   Dim シングル逆出力ファイル名 As String
   Dim 逆展開出力テキストストリームオブジェクト As Object

   シングル逆出力ファイル名 = 現在のパス & "\シングル逆"
   If ファイルシステムオブジェクト.FolderExists(シングル逆出力ファイル名) = False Then
      ファイルシステムオブジェクト.CreateFolder (シングル逆出力ファイル名)
   End If
   移動先フォルダ = 現在のパス & "\シングル逆退避"       ' 退避先フォルダを前もって準備
   If ファイルシステムオブジェクト.FolderExists(移動先フォルダ) = False Then
      ファイルシステムオブジェクト.CreateFolder (移動先フォルダ)
   End If

   シングル逆出力ファイル名 = 現在のパス & "\シングル逆\" & 子品番 & ".txt"

   Set 逆展開出力テキストストリームオブジェクト _
   = ファイルシステムオブジェクト.OpenTextFile(シングル逆出力ファイル名, ForAppending, True)

   出力行 = Chr(34) & 空白 & 検索文字列 & 子品番 & 検索文字列 _
   & 親品番 & Chr(34)

   逆展開出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
   逆展開出力テキストストリームオブジェクト.Close
   Set 逆展開出力テキストストリームオブジェクト = Nothing

End Sub

'************************* 集約展開 ******************************
Private Sub 集約展開()

   Dim 集約展開一覧ファイル名 As String
   Dim LLC別集約展開状況リスト名 As String


   子品番件数 = 0
   ReDim 子品番と構成数の配列(シングル構成件数, 2)

   '★親品番索引を作成★
   Set 子品番索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義

   品番単位の最大集約構成行数 = 0

   If 状況表示 = False Then
      ' 処理を高速化するため、画面描画停止､自動計算停止
       Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
   End If

   '★シングル構成の配列での親品番索引を作成★
   Set シングル構成親品番索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   親品番 = ""
   For 処理行 = 1 To シングル構成件数
      'シングル構成配列の親品番で連想配列の索引を作成
      If 親品番 <> Left(一時配列(処理行), 30) Then
         親品番 = Left(一時配列(処理行), 30) '親品番固定長
         シングル構成親品番索引(親品番) = 処理行 '親品番空白付き
      End If
   Next 処理行

   前レベル終了日時 = Now()

   集約展開一覧ファイル名 = 現在のパス & "\結果\集約展開一覧.txt" '★★★★
   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(集約展開一覧ファイル名) '★★★★

   LLC別集約展開状況リスト名 = 現在のパス & "\結果\LLC別集約展開状況.txt"
   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト2 = _
   ファイルシステムオブジェクト.CreateTextFile(LLC別集約展開状況リスト名)

'   親品番別集約展開のフォルダを作成
   親品番別集約展開ファイル名 = 現在のパス & "\集約"
   If ファイルシステムオブジェクト.FolderExists(親品番別集約展開ファイル名) = False Then
      ファイルシステムオブジェクト.CreateFolder (親品番別集約展開ファイル名)
   End If

   集約展開構成件数 = 0
   ThisWorkbook.Worksheets("ワーク").Activate 'A：集約子品番(固定長テキスト)、B：集約個数(数値)

   For レベル = 最大LLC To 1 Step -1 'ローレベルの大きいものから小さいものに、累積計算する。

      '******親品番リストの該当LLCの親品番を、なめて、出力に送る********
' Stop
      処理内容 = "集約展開レベル = " & レベル
      If レベル Mod 2 = 0 Then
         Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
      Else
         Application.StatusBar = "★☆★" & 処理内容 & "★☆★"
      End If

      If レベル = 最大LLC Then '最下位レベルは、シングル・レベルと同じ結果

         For 処理行 = 1 To 親品番件数
            If 親品番LLC配列(処理行, 2) = レベル Then
               親品番 = 親品番LLC配列(処理行, 1)
               親品番 = Left(親品番 & Space(30), 30) '固定長にする

               行 = 0
               If シングル構成親品番索引.Exists(親品番) = True Then '連想配列を使って、一時配列での該当行を見つける
                  '★シングル構成が存在する場合

                  親品番別集約展開ファイル名 = 現在のパス & "\集約\" & 禁→カナ(RTrim(親品番)) & ".txt"
                  ' 指定ファイルをOPEN(出力モード)
                  Set 出力テキストストリームオブジェクト3 = _
                  ファイルシステムオブジェクト.CreateTextFile(親品番別集約展開ファイル名)

                  Do While Left(一時配列(シングル構成親品番索引(親品番) + 行), 30) = 親品番
                     集約展開構成件数 = 集約展開構成件数 + 1
                     出力行 = 一時配列(シングル構成親品番索引(親品番) + 行)

                     出力テキストストリームオブジェクト.WriteLine 出力行  '集約展開の全体を、固定長で書き出す(親、子、数量

                     出力テキストストリームオブジェクト3.WriteLine Right(出力行, 35) '上位の展開に使うために親品番別に出力

                     '構成品番別最大数量を抽出するため
                     子品番 = Mid(出力行, 31, 30)
                     数量文字 = Right(出力行, 5)

                     If 子品番索引.Exists(子品番) = True Then '連想配列を使って、一時配列での該当行を見つける
                        '★子品番が既存の場合
                        If Val(数量文字) > 子品番と構成数の配列(子品番索引(子品番), 2) Then
                           子品番と構成数の配列(子品番索引(子品番), 2) = Val(数量文字)
                        End If

                     Else
                        '★新規子品番の場合
                        子品番件数 = 子品番件数 + 1
                        子品番索引(子品番) = 子品番件数 '子品番空白付き
                        子品番と構成数の配列(子品番件数, 1) = 子品番
                        子品番と構成数の配列(子品番件数, 2) = Val(数量文字)
                     End If

                     行 = 行 + 1
                  Loop

                  出力テキストストリームオブジェクト3.Close
                  Set 出力テキストストリームオブジェクト3 = Nothing

               End If
            End If
         Next 処理行
      Else '最下位以外は、シングル・レベルと下位のファイルを合体する

         For 処理行 = 1 To 親品番件数
            If 親品番LLC配列(処理行, 2) = レベル Then
               親品番 = 親品番LLC配列(処理行, 1)
               親品番 = Left(親品番 & Space(30), 30) '固定長にする
               ワーク行数 = 0

               行 = 0
               If シングル構成親品番索引.Exists(親品番) = True Then '連想配列を使って、一時配列での該当行を見つける
                  '★シングル構成が存在する場合
                  Do While Left(一時配列(シングル構成親品番索引(親品番) + 行), 30) = 親品番

                     ワーク行数 = ワーク行数 + 1
                     Range("A1").Cells(ワーク行数, 1).value = _
                     Mid(一時配列(シングル構成親品番索引(親品番) + 行), 31, 30) '子品番固定長

                     数量 = Val(Right(一時配列(シングル構成親品番索引(親品番) + 行), 5)) '数量、数値

                     Range("B1").Cells(ワーク行数, 1).value = 数量  '数値
                     子品番 = Mid(一時配列(シングル構成親品番索引(親品番) + 行), 31, 30) '固定長

                     Call 孫探し

                     行 = 行 + 1
                  Loop
               End If '当該レベルでシングル構成に親品番が存在

               If ワーク行数 > 0 Then

                  Range("A1").CurrentRegion.Sort _
                      Key1:=Range("A1"), _
                      Order1:=xlAscending, Header:=xlNo

                  最終行 = Cells(ActiveSheet.Rows.count, 1).End(xlUp).Row

                  行 = 1
                  Do While 行 <= 最終行
                     If Range("A1").Cells(行, 1).value = Range("A1").Cells(行 + 1, 1).value Then '同一孫品番
                        Range("B1").Cells(行, 1).value = Range("B1").Cells(行, 1).value + Range("B1").Cells(行 + 1, 1).value

                        Rows(行 + 1).Delete Shift:=xlUp
                        最終行 = 最終行 - 1
                     Else
                        行 = 行 + 1
                     End If
                  Loop

                  If 品番単位の最大集約構成行数 < 最終行 Then
                     品番単位の最大集約構成行数 = 最終行
                  End If

                  If レベル > 1 Then
                     親品番別集約展開ファイル名 = 現在のパス & "\集約\" & 禁→カナ(RTrim(親品番)) & ".txt"
                     ' 指定ファイルをOPEN(出力モード)
                     Set 出力テキストストリームオブジェクト3 = _
                     ファイルシステムオブジェクト.CreateTextFile(親品番別集約展開ファイル名)
                  End If

                  For 行 = 1 To 最終行
                     集約展開構成件数 = 集約展開構成件数 + 1

                     出力行 = Left(親品番 & Space(30), 30) & Range("A1").Cells(行, 1).value _
                     & Right(Space(5) & CStr(Range("B1").Cells(行, 1).value), 5)

                     出力テキストストリームオブジェクト.WriteLine 出力行     '集約展開の全体を、固定長で書き出す(親、子、数量

                     If レベル > 1 Then
                        出力テキストストリームオブジェクト3.WriteLine Right(出力行, 35) '上位の展開に使うために親品番別に出力
                     End If

                     '構成品番別最大数量を抽出するため
                     子品番 = Mid(出力行, 31, 30)
                     数量文字 = Right(出力行, 5)

                     If 子品番索引.Exists(子品番) = True Then '連想配列を使って、一時配列での該当行を見つける
                        '★子品番が既存の場合
                        If Val(数量文字) > 子品番と構成数の配列(子品番索引(子品番), 2) Then
                           子品番と構成数の配列(子品番索引(子品番), 2) = Val(数量文字)
                        End If

                     Else
                        '★新規子品番の場合
                        子品番件数 = 子品番件数 + 1
                        子品番索引(子品番) = 子品番件数 '子品番空白付き
                        子品番と構成数の配列(子品番件数, 1) = 子品番
                        子品番と構成数の配列(子品番件数, 2) = Val(数量文字)
                     End If

                  Next 行

                  Worksheets("ワーク").Rows("1:12000").Delete Shift:=xlUp
                  Range("A1").Select

                  If レベル > 1 Then
                     出力テキストストリームオブジェクト3.Close
                     Set 出力テキストストリームオブジェクト3 = Nothing
                  End If

               End If '当該親品番に対する集約展開のワークが存在

            End If '親品番が集約対象の当該レベルで、同一親品番の構成範囲

         Next 処理行
      End If

      終了日時 = Now()
      出力行 = "レベル= " & レベル & vbTab & "集約展開構成件数= " & Format(集約展開構成件数, "#,##0") _
      & vbTab & "当該レベル処理時間= " & Format(終了日時 - 前レベル終了日時, "h時間nn分ss秒") _
      & vbTab & "累積= " & Format(終了日時 - 開始日時, "h時間nn分ss秒")
      出力テキストストリームオブジェクト2.WriteLine 出力行     'レベルと、そのレベルでの集約展開構成件数を書き出す
      前レベル終了日時 = 終了日時

   Next レベル 'ローレベルの大きいものから小さいものに、累積計算する。

   出力テキストストリームオブジェクト2.WriteLine "品番単位の最大構成行数= " & 品番単位の最大集約構成行数

   ' 指定ファイルをClose(出力モード)

   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   出力テキストストリームオブジェクト2.Close
   Set 出力テキストストリームオブジェクト2 = Nothing

    ' 画面描画再開､自動計算停止解除
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

   Erase 一時配列
   ReDim 一時配列(1) As String 'これでメモリ消費が抑えられる？

End Sub


'************************* 孫探し ******************************
Private Sub 孫探し()

   子品番ファイル名 = 現在のパス & "\集約\" & 禁→カナ(RTrim(子品番)) & ".txt"

   ' 指定ファイルをOPEN(入力モード)
   On Error GoTo 終了
   'シングルの構成子品番が、親品番に存在しなければ終了。

   Set 部品表構成入力テキストストリームオブジェクト孫 = _
   ファイルシステムオブジェクト.OpenTextFile(子品番ファイル名, 1)

   Do Until 部品表構成入力テキストストリームオブジェクト孫.AtEndOfStream

      入力行 = 部品表構成入力テキストストリームオブジェクト孫.ReadLine

      ワーク行数 = ワーク行数 + 1

      Range("A1").Cells(ワーク行数, 1).value = Left(入力行, 30) '子品番固定長
      Range("B1").Cells(ワーク行数, 1).value = 数量 * Val(Right(入力行, 5)) '親の数量掛ける子の数量、数値

   Loop

   ' 指定ファイルをClose(入力モード)
   部品表構成入力テキストストリームオブジェクト孫.Close
   Set 部品表構成入力テキストストリームオブジェクト孫 = Nothing

終了:

End Sub


Private Sub 子品番最大数リストを出力()

   Dim 出力リスト名 As String

   処理内容 = "子品番配列を並び替え"
   Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   Call クイックソート2次元配列(子品番と構成数の配列, 1, 子品番件数)

   '★★子品番、最大数を txt 出力★★

   出力リスト名 = 現在のパス & "\結果\子品番と最大数リスト.txt"
   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力リスト名)

   For 処理行 = 1 To 子品番件数
      出力行 = RTrim(子品番と構成数の配列(処理行, 1)) & vbTab & 子品番と構成数の配列(処理行, 2)
      出力テキストストリームオブジェクト.WriteLine 出力行
   Next 処理行

   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing

End Sub

Function 禁→カナ(ByVal 文字列 As String)
         文字列 = Replace(文字列, "/", "ス")
         文字列 = Replace(文字列, "*", "ア")
         文字列 = Replace(文字列, "\", "￥")
         文字列 = Replace(文字列, ":", "：")
         文字列 = Replace(文字列, "?", "？")
         文字列 = Replace(文字列, ">", "＞")
         文字列 = Replace(文字列, "<", "＜")
         文字列 = Replace(文字列, "|", "│")
         禁→カナ = Replace(文字列, Chr(34), "ク")
End Function

Private Sub CSV読み込み()

   Dim フォルダパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim ファイル名 As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream

   Dim シート As Worksheet
   Dim 追加シート名初期 As String

   Dim 重複 As Integer
   Dim シート数 As Integer

   Dim フリー As Integer
   Dim ファイル数 As Integer
   Dim 出力行 As Integer
   Dim レベル As Integer
   Dim データ配列(28) As String
   Dim 親品番配列(10, 28) As Variant
   Dim 配列縦() As Variant
   Dim 配列横() As Variant
   Dim インデックス As Integer

    ThisWorkbook.Activate

    追加シート名初期 = "シングル・レベル抽出結果"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("CSVレイアウト").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名

    Call 印刷設定

   ChDrive (ThisWorkbook.Path)
   ChDir (ThisWorkbook.Path)

    '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
    フォルダパス = Application.GetOpenFilename("CSVファイル,*.csv")

    '[ファイルを開く]で「キャンセル」した場合は、処理を終了
    If フォルダパス = "False" Then End

    開始時刻 = Now

    'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
    フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))

   'ファイルシステム・オブジェクトを使って、フォルダ、ファイルを操作する
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(フォルダパス)

   '★指定した CSV の存在するフォルダの全ての CSV ファイルを対象
   ファイル数 = 0
   出力行 = 5

   For Each ファイル In フォルダ.Files

      ファイル名 = ファイル.Name

      'ファイルの拡張子を調べて、CSV ファイルのみを、置換対象とする
      If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "csv" Then

         'ファイルが、CSV ファイルだったら
         ファイル数 = ファイル数 + 1
         Erase 親品番配列

         Application.StatusBar = "読み込み中です．．．．" & ファイル数 & " " & ファイル名

         ' FreeFile値の取得(以降この値で入出力する)
         フリー = FreeFile
         ' 指定ファイルをOPEN(入力モード)
         Open ファイル名 For Input As #フリー

         ' ファイルのEOF(End of File)まで繰り返す
         Do Until EOF(フリー)

             ' レコードを読み込む(28項目のCSV)
             Input #フリー, データ配列(1), データ配列(2), データ配列(3), データ配列(4), データ配列(5) _
             , データ配列(6), データ配列(7), データ配列(8), データ配列(9), データ配列(10) _
             , データ配列(11), データ配列(12), データ配列(13), データ配列(14), データ配列(15) _
             , データ配列(16), データ配列(17), データ配列(18), データ配列(19), データ配列(20) _
             , データ配列(21), データ配列(22), データ配列(23), データ配列(24), データ配列(25) _
             , データ配列(26), データ配列(27), データ配列(28)

             If IsNumeric(データ配列(14)) = True Then  'レベルが数字の場合
               レベル = データ配列(14)
               For インデックス = 4 To 15
               'インデックス = 4 To 15 が、CSV から取り込んだデータの内、シングル・レベル・データに使う項目
                  親品番配列(レベル + 1, インデックス) = データ配列(インデックス)
                  'レベル毎の最終行データを、レベル毎に親品番配列(レベル)に保持する
                  'レベルは 0 から始まるのに、配列を Option Base 1 としているので、1加算している
               Next インデックス
             ElseIf データ配列(14) = "" Then '親品番のレベルには空白が存在
               レベル = 0
               For インデックス = 4 To 15
                  親品番配列(レベル + 1, インデックス) = データ配列(インデックス)
                  'レベル毎の最終行データを、レベル毎に親品番配列(レベル)に保持する
                  'レベルは 0 から始まるのに、配列を Option Base 1 としているので、1加算している
               Next インデックス
             Else
               GoTo 次の行へ
             End If

              Erase 配列縦
              Erase 配列横

              配列縦 = WorksheetFunction.Transpose(データ配列) '一元配列の「データ配列」を二次元配列にする
              配列横 = WorksheetFunction.Transpose(配列縦) '上で縦方向の配列になってしまったので、横方向の配列に戻す

                 Worksheets(追加シート名).Range("F1").Cells(出力行, 1).Resize(1, 28) = 配列横

                 If レベル > 0 Then
                    If 親品番配列(レベル, 4) = データ配列(4) Then '親品番と子品番のユニットが同一の場合のみ
                       Worksheets(追加シート名).Range("A1").Cells(出力行, 1) = 親品番配列(レベル, 4)
                       'ユニット、配列指数のレベルは1加算されている
                       Worksheets(追加シート名).Range("B1").Cells(出力行, 1) = 親品番配列(レベル, 11)  '品番
                       Worksheets(追加シート名).Range("C1").Cells(出力行, 1) = 親品番配列(レベル, 12) '品名
                       Worksheets(追加シート名).Range("D1").Cells(出力行, 1) = 親品番配列(レベル, 14)
                       'レベル、このレベルはオリジナルのまま
                       Worksheets(追加シート名).Range("E1").Cells(出力行, 1) = 親品番配列(レベル, 15)  '数量
                    End If
                 End If
              出力行 = 出力行 + 1
次の行へ:
         Loop
         ' 指定ファイルをCLOSE
         Close #フリー

      End If 'CSV ファイルのみ

   Next '★ファイル

   'オブジェクトを解放する
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

End Sub

Dim MyString, MyNumber
Open "TESTFILE" For Input As #1       ' シーケンシャル入力モードで開きます。
Do While Not EOF(1)                   ' ファイルの終端までループを繰り返します。
    Input #1, MyString, MyNumber      ' データを 2 つの変数に代入します。
    Debug.Print MyString, MyNumber    ' イミディエイト ウィンドウに表示します。
Loop
Close #1                              ' ファイルを閉じます。

Dim MyIndex, FileNumber
For MyIndex = 1 To 5                         ' ループを 5 回繰り返します。
    FileNumber = FreeFile                    ' 未使用のファイル番号を取得します。
    Open "TEST" & MyIndex For Output As #FileNumber    ' ファイル名を作成します。
    Write #FileNumber, "これはサンプルです。"          ' 文字列を出力します。
    Close #FileNumber                        ' ファイルを閉じます。
Next MyIndex