必ず使うシリーズ Excel VBA テキストファイルの改行をセル内改行と置換する関数 Replace Carriage Return Function

コンマ区切りCSVファイルで改行やコンマを入れる方法はある

テキストで基本的に有効なのはダブルクォーテーションで区切る方法
"a","2000","3000"
しかしこの方法では
"a","2,000","本当は3,"000"円"
というような区切りは3列にならない可能性があります。
このとき、数式で結合すれば可能になります。
"a","="&"2"&char(44)&"000","="本当は3"&chahr(44)&"000"&char(44)&"円"
`

RplsCrTxtToCell Replace Carriage Retern (vbCrLF) Cr+LF

Windowsの通常のテキストの改行コードvbCrLfをExcelのセル内の改行コードに変換する

Function RplsCrTxtToCell(str As String) As String
'Windowsの通常のテキストの改行コードvbCrLfをExcelのセル内の改行コードに変換する
'エラーの場合は空白を返す
On Error Resume Next
RplsCrTxtToCell = CStr(Replace(str, vbCrLf, Chr(10) & Chr(13)))
On Error GoTo 0
Exit Function
If Err.Number <> 0 Then RplsCrTxtToCell = "": Err.Clear: Exit Function
End Function
Function RplsCrCelltoTxt(str As String) As String
'http://www.officetanaka.net/excel/vba/tips/tips89.htm
'セル内の改行をWindowsのテキストファイルの改行コードvbCrLfに変換する
'エラーの場合は空白を返す
On Error Resume Next
ReplaceCellTxtCarrigeRtn = CStr(Replace(str, vbLf, vbCrLf))
On Error GoTo 0
Exit Function
If Err.Number <> 0 Then ReplaceCellTxtCarrigeRtn = "": Err.Clear: Exit Function
End Function

DelCrCellTxtCr

セル内の改行LFをすべて削除する

Delete carriage returen in cell

Function DelCrCellTxt(str As String) As String
'Cell内の改行Carriage Returnを削除する
'エラーの場合は空白を返す
On Error Resume Next
DelCrCellTxt = CStr(Replace(Replace(Replace(Replace(Replace(str, vbLf, "", 1, -1, vbBinaryCompare), Chr(10) & Chr(13), "", 1, -1, vbBinaryCompare), Chr(13) & Chr(10), "", 1, -1, vbBinaryCompare), Chr(13) & "" & Chr(10), "", 1, -1, vbBinaryCompare), Chr(10) & "" & Chr(13), "", 1, -1, vbBinaryCompare))
Exit Function
On Error GoTo 0
If Err.Number <> 0 Then DelCrCellTxt = "": Err.Clear: Exit Function
End Function

CSV用にComma, Double Quotation, LFを文字列にする

意図的に& ""を入れない場合

Function fnsub(str As String)
Dim Rex: Set Rex = CreateObject("Vbscript.regexp")
Dim buf As String
With Rex
.MultiLine = True
.IgnoreCase = False
.Global = True
.Pattern = "(\n|\r|\,|"")"
If .Test(str) = True Then
buf = str
.Pattern = """"
buf = .Replace(buf, """&char(34)&""")
.Pattern = "\,"
buf = .Replace(buf, """&char(44)&""")
.Pattern = "(\n|\r)"
buf = .Replace(buf, """&char(10)&char(13)&""")
'意図的に & "" & を入れない
.Pattern = "\&"""""
fnsub = "=""" & .Replace(buf, "") & Chr(34)
Debug.Print buf
End If
End With
End Function

改行を伴うセルを含むCSV変換の例(UTF-8)

Sub exportCsvSpciale()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim iRow As Long, iCol As Long, LastRow As Long, LastCol As Long
Dim R As Range, Urng As Range
Dim Sr As Object: Set Sr = CreateObject("ADODB.Stream")
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim buf As String
Dim strUTF8txtFilename As String: strUTF8txtFilename = "C:Hoge\ExportCsvFile.txt" 'ここでテキストファイル名を決めてください。拡張子はtxtでいいです。これをutf-8で記述して、Csvに変換することでBOMが付きます。
Set Urng = ws.UsedRange
With Urng
LastRow = .Rows.Count
LastCol = .Columns.Count
End With
With Sr
.Charset = "utf-8"
.LineSeparator = -1 ' adCRLF
.Mode = 3 'adModeReadWrite
.Type = 2 'adTypeText
.Open
For iRow = 1 To LastRow
  buf = ""
  For iCol = 1 To LastCol
  Set R = ws.Range(ws.Cells(iRow, iCol).Address)
  If iCol <> LastCol Then
    If R.HasFormula Then
      buf = buf & Chr(34) & Replace(ws.Cells(iRow, iCol).Formula, Chr(34), Chr(34) & Chr(34), 1, -1, vbTextCompare) & Chr(34) & ","
    Else
      buf = buf & fnsubStream(ws.Cells(iRow, iCol).Value) & ","
    End If
  Else
    If R.HasFormula Then
      buf = buf & Chr(34) & Replace(ws.Cells(iRow, iCol).Formula, Chr(34), Chr(34) & Chr(34), 1, -1, vbTextCompare) & Chr(34) & vbCrLf
    Else
      buf = buf & fnsubStream(ws.Cells(iRow, iCol).Value) & vbCrLf
    End If
  End If
  Next iCol
  .WriteText buf, adWriteChar
Next iRow
If FSO.FileExists(strUTF8txtFilename) Then FSO.DeleteFile strUTF8txtFilename, True
If FSO.FileExists(Replace(strUTF8txtFilename, ".txt", ".csv", 1, 1, vbTextCompare)) Then FSO.DeleteFile Replace(strUTF8txtFilename, ".txt", ".csv", 1, 1, vbTextCompare), True
Sr.SaveToFile strUTF8txtFilename
FSO.MoveFile strUTF8txtFilename, Replace(strUTF8txtFilename, ".txt", ".csv", 1, 1, vbTextCompare)
End With
Sr.Close
Set Sr = Nothing
End Sub
Function fnsubStream(str As String)
Dim Rex: Set Rex = CreateObject("Vbscript.regexp")
Dim buf As String
With Rex
.MultiLine = True
.IgnoreCase = False
.Global = True
.Pattern = "(\n|\r|\,|"")"
If .Test(str) = True Then
buf = str
.Pattern = """"
buf = .Replace(buf, """&char(34)&""")
.Pattern = "\,"
buf = .Replace(buf, """&char(44)&""")
.Pattern = "(\n|\r)"
buf = .Replace(buf, """&char(10)&char(13)&""")
'意図的に & "" & を入れない
.Pattern = "\&"""""
fnsubStream = """""=""" & Rex.Replace(buf, "") & """"
Else
fnsubStream = str
End If
End With
End Function