readList3.cls

'************************
'**定数
'************************
'シート名
Public Const sheet_list = "抽出リスト"
'項目数
Public Const COLUMN_MAX1 = 50   '元データのカラム数
'その他
Public Const CharSet = "UTF-16" 'リードストリーム用文字コード
Public Const ls = -1    '同じく改行コード LF(10)/CRLF(-1)
Public Const million = "100万円"

'************************
'**ファイル入出力
'************************
'パターン3 パターン2の応用 グルーピングして抽出処理を追加
'       readList(ファイルパス, カラム(項目)数
Function readList(ByRef filePath As String, ByRef colMax As Integer) As Boolean
    Dim buf As String   '読み込みバッファ
    Dim tmp As Variant    '元データの区切り文字除去

    Dim dataArry() As String    'データ格納配列
    Dim crossArry() As String   '行列入れ替え用配列
    Dim buffArry() As String    'グルーピング用配列

    Dim dataCnt As Long 'データ数カウンタ
    Dim syainCnt  As Long '社員数カウント
    Dim millionCnt As Long   '抽出条件該当件数
    Dim keyNew As String    'キー格納変数
    Dim keyOld As String    
    Dim i As Long   '汎用カウンタ
    Dim j As Long   '同上

    '正常 = true
    '異常 = false
    readList = True

    On Error GoTo ErrHdl

    'ファイル読み込み開始
    With CreateObject("ADODB.Stream")
        .CharSet = CharSet
        .LineSeparator = ls
        .Open
        .LoadFromFile(filePath)

        dataCnt = 0   '初期化
        keyNew = "" '初期化
        keyOld = ""

        Do Until .EOS   'end of systemだっけか？EOFとは違うっポイ あんまり調べてない
            buf = ReadText(-2)
            '区切り文字除去後配列に格納
            tmp = Split(buf, ",")

            'ここで初のエラー処理を書いてみる
            'インプットデータをここではじくのはよくないかもしれないが
            'カラム数の違うデータがあった場合エラー
            If COLUMN_MAX1 <> UBound(tmp) Then
                GoTo ErrHdl
            End If

            keyNew = tmp(0) 'キー格納
            If tmp(0) = "会社コード" Then
                ReDim Preserve dataArry(COLUMN_MAX1, dataCnt)
                For i = 0 To colMax '項目行を配列に格納
                    dataArry(i, dataCnt) = tmp(i)
                Next i
                dataCnt = dataCnt + 1
            Else
                If keyNew = keyOld Then 'キーが前のキーと同じならば
                    syainCnt = syainCnt + 1
                    If tmp(2) = million Or tmp(3) = million Then    'この人ら項目に100万円持ってる？
                        millionCnt = millionCnt+ 1
                    End If

                    'バッファ格納用に再宣言
                    ReDim Preserve buffArry(COLUMN_MAX1, syainCnt)
                    For i = 0 To colMax '一時的にバッファに格納
                        buffArry(i, dataCnt) = tmp(i)
                    Next i
                Else    'キーが前キーと違う
                    If syainCnt > 1 And millionCnt > 1 Then
                        '社員数が2人以上(syainCnt > 1)かつ100万円に該当する社員が2人以上(millionCnt > 1)
                        ReDim Preserve dataArry(COLUMN_MAX1, dataCnt + syainCnt)
                        For j = 1 To syainCnt '条件を満たしているのでバッファからデータ配列に格納
                            For i = 0 To colMax
                                dataArry(i, dataCnt) = buffArry(i, j)
                            Next i
                            dataCnt = dataCnt + 1
                        Next j
                    End If
                    
                    ReDim buffArry(COLUMN_MAX1, 0)  'データをデータ配列に格納したのでバッファを初期化
                    syainCnt = 1    '会社に対しての社員数
                    millionCnt = 0

                    If tmp(2) = million Or tmp(3) = million Then    'この人項目に100万円持ってる？
                        millionCnt = millionCnt+ 1
                    End If
                    'バッファの動的2次元配列宣言
                    ReDim Preserve buffArry(COLUMN_MAX1, syainCnt)
                    For i = 0 To colMax '一時的にバッファに格納
                        buffArry(i, dataCnt) = tmp(i)
                    Next i
                End If
            End If
            keyOld = keyNew '旧 ← 新
        Loop

        'インプットデータの会社が1社のみであった場合出力されないので
        'その為の例外処理
        If syainCnt > 1 And millionCnt > 1 Then
            '社員数が2人以上(syainCnt > 1)かつ100万円に該当する社員が2人以上(millionCnt > 1)
            ReDim Preserve dataArry(COLUMN_MAX1, dataCnt + syainCnt)
            For j = 1 To syainCnt '条件を満たしているのでバッファからデータ配列に格納
                For i = 0 To colMax
                    dataArry(i, dataCnt) = buffArry(i, j)
                Next i
                dataCnt = dataCnt + 1
            Next j
        End If
        .Close
    End With

    '一括転記した場合行列が逆で転記されてしまうため入れ替える
    ReDim crossArry(dataCnt, colMax)
    '行列入れ替え
    For j = 0 To colMax
        For i = 0 To dataCnt
            crossArry(i, j) = dataArry(j, i)
        Next i
    Next j

    'シート指定、転記範囲指定して一括転記
    ThisWorkbook.Worksheets(sheet_list).Range("A1:Q" & dataCnt + 1) = crossArry
    'メモリ解放
    Erase dataArry
    Erase crossArry
    Erase tmp
    
    Exit Function

ErrHdl:
    readList = False
End Function