Option Explicit 'Const TextFolder As String = "D:\goo\data5" 'テキスト格納フォルダ 'Const BookFolder As String = "D:\goo\data7" 'excel Book格納フォルダ Dim TextFolder As String Dim BookFolder As String 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 '戻り値 ret = A(TextFolder, BookFolder) If ret = False Then Exit Sub 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 \ 100 'テキストファイル件数が100で割り切れないならBook件数に1加算 If file_count Mod 100 > 0 Then book_count = book_count + 1 End If 'Book作成時のワークシートの数を退避 save_count = Application.SheetsInNewWorkbook 'Book作成時のワークシートの数を100に設定 Application.SheetsInNewWorkbook = 100 '1~Book件数まで繰り返す For book_no = 1 To book_count Set owb = Workbooks.Add 'シート番号を1~100迄繰り返す For sheet_no = 1 To 100 '1シート分を作成する 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~100)を元に、該当シートへテキストファイルを読み込む 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) * 100 + 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) fileNo = FreeFile Open fname For Input As #fileNo 'ファイル終端まで読み込む lno = 0 '1行空読み Line Input #fileNo, text Do Until EOF(fileNo) '1行読み込み Line Input #fileNo, text lno = lno + 1 '空白行なら終了 If RE.test(text) = True Then Exit Do 'A列の該当行へ設定 owb.Worksheets(sheet_no).Cells(lno, "A").Value = text Loop Close #fileNo 'シート名を設定 owb.Worksheets(sheet_no).name = sname '正常終了 set_sheet = True End Function Private Function A(ByRef xFld1 As String, ByRef xFld2 As String) As Boolean A = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "対象フォルダー選択" If .Show = True Then xFld1 = .SelectedItems(1) Else Exit Function End If End With With Application.FileDialog(msoFileDialogFolderPicker) .Title = "保存先フォルダー選択" If .Show = True Then xFld2 = .SelectedItems(1) Else Exit Function End If End With A = True End Function