シートをCSVファイルへ保存する例を示す。
ファイル名の取得、上書きの確認、ファイルが開けることの確認、
書き込みを行っている。
Print #で、1行ずつ(Ln)、ファイルに書き込んでいる。
1つの文字列と認識できるよう、文字列を判別して""で囲んでいる。
Sub CsvWrite()
Dim FilDlg As FileDialog
Dim SfsObj As Object
Dim PasNom As String
Dim SavNom As Variant
Dim Ln As Variant
Dim ir As Long
Dim MaxRow As Long
Dim Mc As Long
Dim ic As Long
Dim MaxClm As Integer
Dim jCncel As Integer
Dim jer As Integer
Dim i As Long
Dim j As Integer
MaxRow = ActiveSheet.UsedRange.Rows.Count
MaxClm = ActiveSheet.UsedRange.Columns.Count
'保存するファイル名を取得する
PasNom = ThisWorkbook.Path
If Right(PasNom, 1) <> "\" Then PasNom = PasNom & "\"
SavNom = PasNom & "test.csv" 'デフォルトファイル名
SavNom = Application.GetSaveAsFilename( _
Title:="保存先の指定", _
InitialFileName:=SavNom, _
FileFilter:="csv形式,*.csv")
If SavNom = False Then
MsgBox "cancelが押されました"
Exit Sub
ElseIf Dir(SavNom) <> "" Then
If MsgBox("同名のファイルが存在します。上書きしますか？", vbYesNo) = _
vbNo Then Exit Sub
End If
On Error Resume Next '開けることの確認
Err.Clear
Open SavNom For Append As #1
Close #1
If Err.Number > 0 Then
MsgBox "ファイルが開けません"
jer = 1
Else
jer = 0
End If
On Error GoTo 0
If jer = 1 Then Exit Sub
Open SavNom For Output As #1
For i = 1 To MaxRow
Mc = 0
For j = MaxClm To 1 Step -1
If Cells(i, j) <> "" Then
Mc = j
Exit For
End If
Next j
Select Case Mc
Case Is < 1
Print #1, vbCrLf
Case 1
If VarType(Cells(i, 1).Value) = vbString Then
Print #1, """" & Replace(Cells(i, 1), vbLf, vbNewLine) & """"
Else
Print #1, Replace(Cells(i, 1), vbLf, vbNewLine)
End If
Case Else
Ln = ""
For j = 1 To Mc - 1
If VarType(Cells(i, j).Value) = vbString Then
Ln = Ln & """" & Replace(Cells(i, j), vbLf, vbNewLine) & ""","
Else
Ln = Ln & Replace(Cells(i, j), vbLf, vbNewLine) & ","
End If
Next j
If VarType(Cells(i, Mc).Value) = vbString Then
Ln = Ln & """" & Replace(Cells(i, Mc), vbLf, vbNewLine) & """"
Else
Ln = Ln & Replace(Cells(i, Mc), vbLf, vbNewLine)
End If
Print #1, Ln
End Select
Next i
Close #1
End Sub