VBAでは単純なテキストのオブジェクトでは
UTF-8の出力できないそうで・・・orz
参考サイト
http://d.hatena.ne.jp/niemands/20090316/1237225383
コチラのサイトを参考にプログラムを作りました
プログラム仕様としては
1行目がタイトルで
2行目以降がデータ
そのデータを読み込んでその内容、
UTF-8のCSVに出力するというものです
このソースにあとはボタンを対応すれば
CSV出力できるプログラムです
ソースは以下のとおり
Sub dsp_file() Dim myTmp As String '出力するデータ Dim bErrorFlag As String Dim w As Worksheet Dim i As Long, j As Long Dim xlAPP As Application ' Applicationオブジェクト Dim X(1 To 23) As Variant ' 書き出すレコード内容 Dim GYO As Long ' 収容するセルの行 Dim GYOMAX As Long ' データが収容された最終行 Dim lngREC As Long ' レコード件数カウンタ Dim COL As Long ' カラム(Work) Dim myPath As String 'フォルダパス Dim Stream 'UTF-8に出力するための変数 Const adTypeText = 2 '出力するためのConst Const adSaveCreateOverWrite = 2 '出力するためのConst '*** 保存するパスの設定 start Dim ShellApp As Object Dim oFolder As Object Set ShellApp = CreateObject("Shell.Application") Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1) myPath = oFolder.items.Item.Path If Dir(myPath, vbDirectory) = "" Then MsgBox "保存するフォルダがありません。保存フォルダ: " & myPath Exit Sub End If '*** 保存するパスの設定 End '*** 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す) start GYOMAX = Cells(65536, 1).End(xlUp).Row If GYOMAX < 2 Then xlAPP.StatusBar = False MsgBox "2行目からデータを入力してください。", , cnsTitle Exit Sub End If '*** 収容最終行の判定 End '*** 最初のデータをセット GYO = 2 '*** UTF-8で出力するためのADOを読み込み start Set Stream = CreateObject("ADODB.Stream") Stream.Open Stream.Type = adTypeText Stream.Charset = "UTF-8" '*** UTF-8で出力するためのADOを読み込み End ' 最終行まで繰り返す Do Until GYO > GYOMAX bErrorFlag = "0" Erase X ' 初期化 ' ① ' 内容をレコードにセット(先頭は2行目) For COL = 1 To 22 X(COL) = Replace(Cells(GYO, COL).Value, vbLf, vbCrLf) ' ② Next COL '***出力用の内容初期化 myTmp = "" '***表示順:1 myTmp = myTmp & """" & X(1) & """" & vbTab '1行ずつ書き込む Stream.WriteText myTmp, adWriteLine GYO = GYO + 1 Loop 'オブジェクトの内容をファイルに保存 Stream.SaveToFile (myPath & "\XXXXXX.csv"), adSaveCreateOverWrite 'オブジェクトを閉じる Stream.Close 'メモリからオブジェクトを削除する Set Stream = Nothing MsgBox myPath & "に取り込み用の楽曲ファイル(csv)を作成しました。" End Sub