Option Explicit

Const TextFolder As String = "F:\server\apple"    'テキスト格納フォルダ
Const BookFolder As String = "F:\server\apple2"    'excel Book格納フォルダ
Dim array_file() As String      'テキストファイル名の配列
Dim owb As Workbook             '出力ブック
Public Sub 全テキスト読込()
    Dim FSO As Object               'FileSystemObject
    Dim srcfolder As Object         'テキストファイルフォルダ
    Dim wfiles As Object            'テキストファイル一覧
    Dim wfile As Object             'テキストファイル
    Dim file_count As Long          'テキストファイルの件数
    Dim book_count As Long          'Bookの件数
    Dim book_no As Long             'ブック番号
    Dim sheet_no As Long            'シート番号
    Dim save_count As Variant       '退避領域
    Dim book_name As String         '出力ブック名
    Dim ret As Boolean              '戻り値
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set srcfolder = FSO.GetFolder(TextFolder)   'テキストファイル格納フォルダ情報取得
    Set wfiles = srcfolder.Files    'ファイル一覧取得
    file_count = 0
    '拡張子が.txtのファイルのみ取得し、array_fileに格納する
    For Each wfile In wfiles
        If LCase(Right(wfile.Name, 4)) = ".txt" Then
            ReDim Preserve array_file(file_count)
            array_file(file_count) = wfile.Name
            file_count = file_count + 1
        End If
    Next
    '出力するBookの件数を求める
    book_count = file_count \ 8
    'テキストファイル件数が8で割り切れないならBook件数に1加算
    If file_count Mod 8 > 0 Then
        book_count = book_count + 1
    End If
    'Book作成時のワークシートの数を退避
    save_count = Application.SheetsInNewWorkbook
    'Book作成時のワークシートの数を8に設定
    Application.SheetsInNewWorkbook = 8
    '1～Book件数まで繰り返す
    For book_no = 1 To book_count
        Set owb = Workbooks.Add
        'シート番号を1～8迄繰り返す
        For sheet_no = 1 To 8
            '１シート分を作成する
            ret = set_sheet(book_no, sheet_no)
            'テキストファイル数の上限を超えているなら打ち切る
            If ret = False Then Exit For
        Next
        'ブック名をBook+連番で出力する
        book_name = BookFolder & "\Book" & book_no & ".xlsx"
        owb.SaveAs Filename:=book_name
        owb.Close
    Next
    '退避したBook作成時のワークシートの数を戻す
    Application.SheetsInNewWorkbook = save_count
    MsgBox ("完了")
End Sub

'ブック番号(1～N)とシート番号(1～8)を元に、該当シートへテキストファイルを読み込む
Private Function set_sheet(ByVal book_no As Long, ByVal sheet_no As Long) As Boolean
    Dim i As Long
    Dim fname As String     'テキストファイル名（フルパス）
    Dim fileNo As Long      'ファイル番号
    Dim lno As Long         '行番号
    Dim text As String      '読み込んだテキスト
    Dim RE As Object        '正規表現オブジェクト
    Dim sname As String     'シート名
    Set RE = CreateObject("VBScript.RegExp")
    '1行が空白行か否かの判定用
    RE.Pattern = "^\s*$"
    RE.Global = True
    set_sheet = False
    'array_fileの何番目かを求める
    i = (book_no - 1) * 8 + sheet_no - 1
    '上限を超えているならFlaseで終了
    If i > UBound(array_file) Then Exit Function
    'テキストファイル名及びその拡張子を除いたものを取得
    fname = TextFolder & "\" & array_file(i)
    sname = array_file(i)
    sname = Left(sname, Len(sname) - 4)
    Dim ADOST As Object
    Set ADOST = CreateObject("ADODB.Stream")
    With ADOST
        .Charset = "UTF-16"
        .Open
        .LoadFromFile fname
        lno = 0
        Do Until (.EOS)
            '1行読み込み
            text = .ReadText(-2)
            lno = lno + 1
            'A列の該当行へ設定
            owb.Worksheets(sheet_no).Cells(lno, "A").Value = text
        Loop
        .Close
    End With
    'シート名を設定
    owb.Worksheets(sheet_no).Name = sname
    '正常終了
    set_sheet = True
End Function