セルの値でフォルダやファイル名とファイルの内容２

質問

昨日質問させていただいて、大丈夫とおもったら、
問題がでてきましたので、再度質問させてください。

（昨日のは締め切ってしまったので。。。）

===やりたい事====

セルの値で
フォルダやファイル名とファイルの内容を一気に保存したいのですが、
どうしても式がわかりません。。

やりたいことはここにまとめてます。
↓
http://bsmile.sakura.ne.jp/phptest/cc1.jpg

１
A列のフォルダと作って、
２
B行のファイル名で、
３
C行の内容のファイルを作りたいのです。

===問題点====

昨日質問させていただいて
こちらのマクロで動くようになり
↓↓↓↓↓↓↓↓↓↓↓↓↓

csvならこの程度、、、
Option Explicit
Sub Ottotto()
Const xPath0 = "C:\Users\user\Desktop\test\"
Dim xSheet As Worksheet
Dim xPath As String
Dim xName As String
Dim xText As String
Dim nn As Integer
Application.DisplayAlerts = False
Set xSheet = ActiveSheet
For nn = 1 To xSheet.Range("A" & Rows.Count).End(xlUp).Row
xName = xSheet.Cells(nn, "B").Value
xText = xSheet.Cells(nn, "C").Value
xPath = (xPath0 & xSheet.Cells(nn, "A").Value & "\")
If (Dir(xPath, vbDirectory) = vbNullString) Then
MkDir xPath
End If
ChDrive (Left(xPath, 1))
ChDir (xPath)
With Workbooks.Add
Worksheets(1).Cells(1, "A").Value = xText
.SaveAs (xPath & xName & ".csv")
.Close False
End With
Next
Application.DisplayAlerts = True
End Sub

できた.csvファイルは確かにエクセルでひらけたので
すっかり、安心していたのですが、

たとえば、できたｃｓｖファイルをメモ帳やテラパッドのようなエディターで開いたら
「NULLがどーの」と文字化けの塊みたいになります。

基本的にできたファイルはメモ帳などで開きたいのですが、、、、

多分スクリプトの書き込む際の文字コードだとおもうのですが、
With Workbooks.Add
Worksheets(1).Cells(1, "A").Value = xText
.SaveAs (xPath & xName & ".csv")
.Close False
このあたり、どうスクリプトを書込めばいいかわかりません。

どなたかおしえていただけないでしょうか？？

どうぞよろしくお願いいたします。

回答No.2

K Kazz（@JazzCorp）

txtファイル書出し版
Option Explicit
Sub Ottotto()
Const xPath0 = "C:\Users\user\Desktop\test\"
Const xExtent = ".txt"
Dim xSheet As Worksheet
Dim xPath As String
Dim xName As String
Dim xText As String
Dim xFF02 As Integer
Dim xREC As String
Dim nn As Integer
Application.DisplayAlerts = False
Set xSheet = ActiveSheet
For nn = 1 To xSheet.Range("A" & Rows.Count).End(xlUp).Row
xName = xSheet.Cells(nn, "B").Value
xText = xSheet.Cells(nn, "C").Value
xPath = (xPath0 & xSheet.Cells(nn, "A").Value & "\")
If (Dir(xPath, vbDirectory) = vbNullString) Then
MkDir xPath
End If
ChDrive (Left(xPath, 1))
ChDir (xPath)
xFF02 = FreeFile()
Open (xPath & xName & xExtent) For Output As #xFF02
Print #xFF02, xText
Close
Next
Application.DisplayAlerts = True
End Sub

お礼

ありがとうございます

回答No.1

noname#203218

下記でテキスト保存されます。

Sub Ottotto()
Const xPath0 = "C:\Users\user\Desktop\test\"
Dim xSheet As Worksheet
Dim xPath As String
Dim xName As String
Dim xText As String
Dim nn As Integer
Dim FSO, Textfile As Object

Application.DisplayAlerts = False
Set xSheet = ActiveSheet
For nn = 1 To xSheet.Range("A" & Rows.Count).End(xlUp).Row
xName = xSheet.Cells(nn, "B").Value
xText = xSheet.Cells(nn, "C").Value
xPath = (xPath0 & xSheet.Cells(nn, "A").Value & "\")
If (Dir(xPath, vbDirectory) = vbNullString) Then
MkDir xPath
End If

Set FSO = CreateObject("Scripting.FileSystemObject")
Set Textfile = FSO.OpenTextFile(xPath & xName & ".txt", 2, True)
Textfile.Write xText
Textfile.Close
Set FSO = Nothing
Set Textfile = Nothing

Next
Application.DisplayAlerts = True
End Sub

お礼

ありがとうございます