【VBA】CSVに配列の中身を書き出す｜ADODB.Stream

Public Sub SaveUtf8WithBom(byval filePath As String, byval content As String)

    ' UTF-8で書き込む（まずはBOMなしで）
    Dim stTxt As Object: Set stTxt = CreateObject("ADODB.Stream")
    With stTxt
        .Type = 2  ' テキストモード
        .Charset = "utf-8"
        .Open
        .WriteText content
        .Position = 0
    End With

    ' バイナリファイルを作成
    Dim stBin As Object: Set stBin = CreateObject("ADODB.Stream")
    With stBin
        .Type = 1
        .Open

        ' バイナリファイルにBOMを追加する
        Dim bom(2) As Byte
        bom(0) = &HEF
        bom(1) = &HBB
        bom(2) = &HBF

        .Write bom

        ' テキストファイルをバイナリファイルにコピーする
        stTxt.CopyTo stBin

        ' バイナリファイルをファイルに保存する
        .SaveToFile filePath, 2

        .Close
    End With

    ' テキストファイルを閉じる
    stTxt.Close
End Sub

Dim st As Object
Set st = CreateObject("ADODB.Stream")

st.Type = 2          ' テキストモード
st.Charset = "utf-8" ' 文字コード設定

st.Open              ' ←ここで「ストリームを開く」
st.WriteText "Hello"

'列：列記号で指定
private const COL_LASTROW_BASE = "A" ' 最終行の基準とする列記号

'ヘッダー行、データ行の開始行: 行番号で指定
private const ROW_HEADER = 1
private const ROW_DATA_START = 2

Public Sub ExportSheetToCSV()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("対象シート")

    ' 出力列を定義
    dim fields() as string
    ReDim fields(0 To 4)
    fields(0) = "A"
    fields(1) = "C"
    fields(2) = "E"
    fields(3) = "F"
    fields(4) = "G"

    ' 最終行、最終列を取得
    Dim lastRow As Long, lastCol As Long
    With ws
        lastRow = .Range(COL_LASTROW_BASE & .Rows.Count).End(xlUp).Row
        lastCol = .Cells(ROW_HEADER, .Columns.Count).End(xlToLeft).Column
    End With

    ' CSV行データを格納する配列
    Dim csvLines() As String
    Dim rowData() As String
    Dim line As String

    Dim i As Long
    ' ヘッダー行のデータを格納する配列
    ReDim rowData(LBound(fields) To UBound(fields))
    For i = LBound(fields) To UBound(fields)
        rowData(i) = CSVEscape(ws.Cells(ROW_HEADER, fields(i)).Value)
    Next

    ' CSV行データを格納する配列
    ReDim csvLines(0 To lastRow - ROW_DATA_START + 1)

    ' 1行目にヘッダー行を出力
    line = Join(rowData, ",")
    csvLines(0) = line

    ' 行データの処理（各行を1つずつstringにする）
    Dim r As Long
    For r = ROW_DATA_START To lastRow

        For i = LBound(fields) To UBound(fields)
            rowData(i) = CSVEscape(ws.Cells(r, fields(i)).Value)
        Next i

        ' CSV1行にまとめる
        line = Join(rowData, ",")

        ' CSV配列に追加
        csvLines(r -ROW_DATA_START + 1) = line

    Next r

    ' CSV文字列
    Dim csvContent As String
    csvContent = Join(csvLines, vbCrLf)

    Dim csvFilePath As String
    csvFilePath = "ここに保存先パスを指定する"

    ' CSVファイルに保存
    SaveUtf8WithBom csvFilePath, csvContent
End Sub

'=== ダブルクォートを必要な時だけ付ける ===
Private Function CsvEscape(byval s As String) As String
    Dim needQuote As Boolean
    needQuote = (InStr(s, ",") > 0) Or (InStr(s, """") > 0) Or (InStr(s, vbCr) > 0) Or (InStr(s, vbLf) > 0)

    If needQuote Then
        CsvEscape = """" & Replace(s, """", """""") & """"
    Else
        CsvEscape = s
    End If
End Function

Dim sb As String
For r = 1 To lastRow
    sb = sb & line & vbCrLf
Next

Dim arr() As String, idx As Long
ReDim arr(1 To lastRow)

For r = 1 To lastRow
    arr(idx) = line
    idx = idx + 1
Next

sb = Join(arr, vbCrLf)