Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8669 / 13644 ツリー ←次へ | 前へ→

【31867】テキストファイルの改行コードを変換 ほびっと 05/12/1(木) 16:24 質問[未読]
【31879】Re:テキストファイルの改行コードを変換 Hirofumi 05/12/1(木) 19:52 回答[未読]
【31886】Re:テキストファイルの改行コードを変換 ichinose 05/12/1(木) 21:04 発言[未読]
【31914】Re:テキストファイルの改行コードを変換 ほびっと 05/12/2(金) 10:17 お礼[未読]

【31867】テキストファイルの改行コードを変換
質問  ほびっと  - 05/12/1(木) 16:24 -

引用なし
パスワード
   Excel2002/Win2000です。

指定したテキストファイルの改行コードが
 CR+LFの場合、何もしない
 LFの場合、CR+LFに変換する
上記をExcelでやりたいのですが、アドバイスをお願いします。

【31879】Re:テキストファイルの改行コードを変換
回答  Hirofumi  - 05/12/1(木) 19:52 -

引用なし
パスワード
   CSVReadFSOは、Lf改行のTextをシートに読み込みます
Conversionは、Lf改行をCrLfに変換します

Option Explicit

Public Sub CSVReadFSO()
  
'  Lfの改行コードのCSVをシートに読み込み

  Dim vntFileName As Variant
  Dim strFilter As String
  Dim wksWrite As Worksheet
  Dim lngRow As Long
  Dim lngCol As Long
  Dim vntField As Variant
  Dim strBuff As String
  Dim strProm As String
  Dim objFso As Object
  Dim objFileStr As Object
  Const ForReading = 1
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv"
  '「ファイルを開く」ダイアログを表示
  vntFileName _
      = Application.GetOpenFilename(strFilter, 1)
  If VarType(vntFileName) = vbBoolean Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '書き込むシートを設定
  Set wksWrite = ActiveSheet
  '書き込み開始行を設定
  lngRow = 1
  '書き込み開始列を設定
  lngCol = 1
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  '指定ファイルを読み込みモードでOpen
  Set objFileStr = objFso.OpenTextFile(vntFileName, ForReading)
  
  With objFileStr
    'ファイルの終り迄繰り返し
    Do Until .AtEndOfStream
      'ファイルから1行読み込み
      strBuff = .ReadLine
      'CSVをフィールドに分割
      vntField = Split(strBuff, ",")
      '指定シートの指定行列位置について
      With wksWrite.Cells(lngRow, lngCol)
        'フィールドの書き込み
        .Resize(, UBound(vntField) + 1).Value = vntField
      End With
      '書き込み行位置を更新
      lngRow = lngRow + 1
    Loop
    'ファイルをClose
    .Close
  End With
  
  strProm = "処理が完了しました"

Wayout:
  
  Set objFileStr = Nothing
  Set objFso = Nothing
  Set wksWrite = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Public Sub Conversion()

'  改行コード(Lf→CrLf)の変換

  Dim dfn As Integer
  Dim vntInFile As Variant
  Dim vntOutFile As Variant
  Dim strFilter As String
  Dim strBuff As String
  Dim strProm As String
  Dim objFso As Object
  Dim objFileStr As Object
  Const ForReading = 1
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv"
  '「ファイルを開く」ダイアログを表示
  vntInFile = Application.GetOpenFilename(strFilter, 1)
  If VarType(vntInFile) = vbBoolean Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '「ファイルを保存」ダイアログを表示
  vntOutFile = Application.GetSaveAsFilename(vntOutFile, strFilter, 1)
  If vntOutFile = False Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  If vntInFile = vntOutFile Then
    strProm = "入力側と出力側のファイル名を別にして下さい"
    GoTo Wayout
  End If
    
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  '指定ファイルを読み込みモードでOpen
  Set objFileStr = objFso.OpenTextFile(vntInFile, ForReading)
  
  '出力ファイルをOpen
  dfn = FreeFile
  Open vntOutFile For Output As dfn
  
  With objFileStr
    'ファイルの終り迄繰り返し
    Do Until .AtEndOfStream
      'ファイルから1行読み込み
      strBuff = .ReadLine
      'ファイルに1行出力
      Print #dfn, strBuff
    Loop
    'ファイルをClose
    .Close
    Close dfn
  End With
  
  strProm = "処理が完了しました"

Wayout:
  
  Set objFileStr = Nothing
  Set objFso = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

'「CSVReadFSO」で使用
Public Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

'「CSVReadFSO」、「Conversion」で使用
Public Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

【31886】Re:テキストファイルの改行コードを変換
発言  ichinose  - 05/12/1(木) 21:04 -

引用なし
パスワード
   こんばんは。
テキストファイル限定なら
'==============================================
Sub test()
  Dim flnm As Variant
  flnm = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt,csvファイル,*.csv", , _
            "LF--->CRLF変換を行うテキストファイルを選択してください")
  If TypeName(flnm) <> "Boolean" Then
    infno = FreeFile()
    Open flnm For Input As #infno
    outfno = FreeFile()
    Open ThisWorkbook.Path & "\exceltemp.tmp" For Output As #outfno
  
    Do Until EOF(infno)
     Line Input #infno, dat
     Print #outfno, Replace(dat, vbLf, vbCrLf)
     Loop
    Close #infno
    Close #outfno
    Kill flnm
    Name ThisWorkbook.Path & "\exceltemp.tmp" As flnm
   
    End If
End Sub


新規ブックの標準モジュールに上記のコードを貼り付けて
一度保存してから実行してください。

尚、実行時には、ブックと同じフォルダにexceltemp.tmpというテンポラリファイルを
作成されます。

【31914】Re:テキストファイルの改行コードを変換
お礼  ほびっと  - 05/12/2(金) 10:17 -

引用なし
パスワード
   Hirofumiさん ichinoseさん さっそくの回答ありがとうございます。
おかげさまで目的とするものができました。
大変に助かり、勉強になりました。
ありがとうございました!

8669 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free