readList2.cls

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

'************************
'**ファイル入出力
'************************
'パターン1 データ数&項目数がわかっている場合
'       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 dataCnt As Long 'データ数カウンタ
    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   '初期化
        Do Until .EOS   'end of systemだっけか？EOFとは違うっポイ あんまり調べてない
            buf = ReadText(-2)

            '区切り文字除去後配列に格納
            tmp = Split(buf, ",")

            'ここでは特段、例のデータ等を示してないので
            '抽出処理も適当です。
            If データ抽出条件 Then
                '2次元配列再宣言
                '列方向に配列が増えていく感じ
                ReDim Preserve dataArry(COLUMN_MAX1, dataCnt)
                For i = 0 To colMax '配列に格納
                    dataArry(i, dataCnt) = tmp(i)
                    i = i + 1
                Next i
                dataCnt = dataCnt + 1
            End If
        Loop
        .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
    
    Exit Function

ErrHdl:
    readList = False
End Function