CSVファイルの情報をテキストファイルに吐き出す方法

質問

• VBもしくはエクセル付随のVBを使用して、CSVファイルの情報をテキストファイルに吐き出す方法を紹介します。
• 特定セルの文字列を雛形テキストファイルの内容で置換して吐き出すことができます。
• また、任意の名前でディレクトリを作成し、指定したディレクトリ内にファイルを保存することも可能です。

回答No.4

1050 円（@1050YEN） · ベストアンサー

Option Explicit

Const DEF_雛形 As String = "C:\aaa\hinagata.txt"
Const DEF_DATA As String = "C:\aaa\data.csv"
Const DEF_OUT_NAME As String = "kyokumei.txt"

Private m_fsoObj As FileSystemObject

Sub Main()
　Set m_fsoObj = New FileSystemObject

　'雛形読込
　Dim l_str雛形　 As String
　l_str雛形 = Get雛形(DEF_雛形)

　'データファイル
　Dim l_fsoFile　 As File
　Set l_fsoFile = m_fsoObj.GetFile(DEF_DATA)

　'接続する
　Dim l_adoCnn As Connection
　Set l_adoCnn = Get接続(l_fsoFile.ParentFolder.Path)

　Dim l_strSQL As String
　l_strSQL = "SELECT * FROM [" & l_fsoFile.Name & "]"

　Dim l_adoRec As Recordset
　Set l_adoRec = l_adoCnn.Execute(l_strSQL)

　Do Until l_adoRec.EOF
　　Dim l_strBuff　 As String

　　'雛形の文字を置換する
　　l_strBuff = Replace(l_str雛形, "[アーティスト名]", l_adoRec("アーティスト名"))
　　l_strBuff = Replace(l_strBuff, "[曲名]", l_adoRec("曲名"))

　　'フォルダ作成処理
　　Dim l_strDir As String
　　l_strDir = l_adoRec("artistname")

　　Dim l_fsoDir As Folder
　　On Error Resume Next
　　'フォルダを作成
　　Set l_fsoDir = l_fsoFile.ParentFolder.SubFolders.Add(l_strDir)
　　If (Err.Number <> 0&) Then
　　　Set l_fsoDir = l_fsoFile.ParentFolder.SubFolders(l_strDir)
　　End If
　　On Error GoTo 0
　　Debug.Print l_fsoDir.Path

　　'テキスト出力処理
　　Dim l_ts As TextStream
　　Set l_ts = l_fsoDir.CreateTextFile(DEF_OUT_NAME, True)
　　l_ts.WriteLine l_strBuff
　　l_ts.Close

　　l_adoRec.MoveNext
　Loop

　MsgBox "終了"
End Sub

'雛形の取得
Private Function Get雛形(ByVal p_strFile As String) As String
　Dim l_fsoFile　 As Scripting.File
　Set l_fsoFile = m_fsoObj.GetFile(p_strFile)

　Dim l_ts As TextStream
　Set l_ts = l_fsoFile.OpenAsTextStream(ForReading)
　Dim l_strBuff As String
　l_strBuff = l_ts.ReadLine
　l_ts.Close

　Get雛形 = l_strBuff
End Function

'フォルダに接続
Function GetConnection(p_strPath As String) As Connection
　Dim l_strCnn As String
　l_strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & p_strPath & ";Extended Properties='text;HDR=YES;FMT=Delimited'"

　Dim l_adoCnn As Connection
　Set l_adoCnn = New Connection

　l_adoCnn.Open l_strCnn
　Set Get接続 = l_adoCnn
End Function

お礼

時間を割いて頂き有り難うございました。
ソースが理解できるよう勉強して行きたいと思います。