| Top Page | プログラミング | テキスト保存／読み込み |

' ディレクトリ中のテキストファイルを，それぞれ一枚のワークシートとして，
' ひとつのワークブック（ファイル）に一括して読み込む．
'
'　　Coded by TAKENAKA, A. 2006-01-23
'    Revised by TAKENAKA, A. 2010-09-06

Sub LoadTextFiles()
   
    n_Suffix = Cells(4, 1).Value    ' 対象ファイルの拡張子の情報
    suf_File = Cells(5 + n_Suffix, 1).Value
    n_separator = Cells(4, 2).Value  ' 一行中のデータの区切り文字の情報
    
    byTab = True
    byComma = False
    bySpace = False
    conseq = False
    
    If (n_separator = 1) Then  ' タブ区切り
        byTab = True
        byComma = False
        bySpace = False
        conseq = False
    ElseIf (n_separator = 2) Then    ' コンマ区切り
        byTab = False
        byComma = True
        bySpace = False
        conseq = False
    ElseIf (n_separator = 3) Then    ' スペース区切り
        byTab = False
        byComma = False
        bySpace = True
        conseq = True  ' 連続したスペースはひとつの区切りとみなす
    Else
        MsgBox "データ区切りの選択が不正です．"
        Exit Sub
    End If
    
    ' 作製するファイル名を指定
    
    ver = Application.Version
    If ver * 1 >= 12 Then ' 2007 以降
        file_filter = "Excel File,*.xlsx;*.xlsm,Excel 2003,*.xls"
     Else  ' 2003 以前
        file_filter = "Excel File,*.xls"
    End If
    
    Target = Application.GetSaveAsFilename(InitialFileName:="", _
                         FileFilter:=file_filter)

    If Target = False Then  ' ファイル名を指定しなかったら終了
        Exit Sub
    End If
  
    ' 新規作成ブックのシート数の設定を保存してから，１枚に設定．
    With Application
        n_Sheets = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
    End With
        
'    MsgBox ("Target  = " & Target)

    ' 新しいワークブックを作り，上で指定した名前で保存．
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=Target
   
    Set TargetBook = ActiveWorkbook

    ' フォルダ内の，指定した拡張子を持つファイル名（ひとつ）を取得
    file = Dir(TargetBook.Path & "\*" & suf_File)
    
    If file = "" Then
        MsgBox "テキストファイルはありません。"
        Exit Sub
    End If
    
    count_file = 0  '該当テキストファイル数を数える．
    While file <> ""
        count_file = count_file + 1
        file = Dir
    Wend
    
    rvl = MsgBox(count_file & "個のテキストファイルを読み込みます", 33, "確認")
    If (rvl <> vbOK) Then ' [OK] でないなら中止
        Exit Sub
    End If
    
    ' あらためて，指定した拡張子を持つファイル名（ひとつ）を取得
    file = Dir(TargetBook.Path & "\*" & suf_File)
    count_file = 1
    While file <> ""
        ' テキストファイルを読み込む
        Workbooks.OpenText Filename:=file, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=conseq, _
        Tab:=byTab, Semicolon:=False, Comma:=byComma, Space:=bySpace, _
        Other:=False, TrailingMinusNumbers:=True
            
       '  ファイルを読み込んで作られたシートを , 作成中のファイルへのコピー
        Sheets(1).Select
        Sheets(1).Move After:=TargetBook.Sheets(count_file)
        
        file = Dir  ' 次のファイル名を取得
        count_file = count_file + 1
    
    Wend
    
    Application.DisplayAlerts = False  ' 確認メッセージを抑止
    
    Sheets(1).Select  ' 最初にできた空のシートを選択．
    ActiveWindow.SelectedSheets.Delete ' シートの削除
    TargetBook.SaveAs Filename:=Target  ' ファイルを保存
   
    Application.DisplayAlerts = True  ' 確認メッセージの抑止を解除

    ' 新規作成ブックのシート数の設定をもとに戻す．
    Application.SheetsInNewWorkbook = n_Sheets
    
End Sub