• WindowsとMacの両対応。ADODB.Streamを使用しているため、参照設定で、Microsoft ActiveX Data Objects x.x Library を追加して下さい。

Option Explicit
 
Sub SaveAsCSV()
 
    If Application.OperatingSystem Like "*Mac*" Then
        SaveAsCSVForMac
    Else
        SaveAsCSVForWin
    End If
 
End Sub
 
Sub SaveAsCSVForWin()
 
    '==============================
    ' 使用しているデータ範囲の取得
    '==============================
    Dim maxRow As Long
    Dim startRow As Long
    Dim maxCol As Long
    Dim startCol As Long
 
    '検索対象のセル
    Dim CsvTop As Range
    Dim CsvRight As Range
    Dim CsvButtom As Range
 
    'セルの検索
    Set CsvTop = Range("A1:CZ2048").Find(What:="CSV_TOP", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    Set CsvRight = Range("A1:CZ2048").Find(What:="CSV_RIGHT", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    Set CsvButtom = Range("A1:CZ2048").Find(What:="CSV_BUTTOM", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
 
   'セルが見つかったかチェック
    If (CsvTop Is Nothing And CsvRight Is Nothing And CsvButtom Is Nothing) Then
        MsgBox "出力失敗 セルに CsvTop, CsvRight, CsvButtomの記述がありません"
    End If
 
    startRow = CsvTop.Row + 1
    maxRow = CsvButtom.Row - 1
    startCol = CsvTop.Column + 1
    maxCol = CsvRight.Column - 1
 
 
    '==============================
    ' ストリームの準備
    '==============================
    Dim outStream As ADODB.Stream
    Set outStream = New ADODB.Stream
 
    'エンコーディングを指定
    With outStream
        .Type = adTypeText
        .Charset = "UTF-8"
        .LineSeparator = adLF
    End With
    outStream.Open
 
    '==============================
    ' ストリームにデータを流し込む
    '==============================
 
    Dim r As Long
    Dim c As Long
    Dim line As String
 
    '1 行ずつ処理
    For r = startRow To maxRow
 
        '1 列目はカンマなし
        line = ActiveSheet.Cells(r, startCol)
 
        '2 列目以降
        For c = startCol + 1 To maxCol
            line = line & "," & ActiveSheet.Cells(r, c)
        Next
 
        'r 行目のデータを StroutStre
        am.WriteText line, adWriteLine
    Next
 
    '==============================
    ' 先頭の BOM を削除
    '==============================
    'BOM の分 3 バイトをスキップ
    outStream.Position = 0
    outStream.Type = adTypeBinary
    outStream.Position = 3
 
    'コピー用のストリーム
    Dim csvStream As ADODB.Stream
    Set csvStream = New ADODB.Stream
 
    'バイナリモードで開く
    csvStream.Type = adTypeBinary
    csvStream.Open
 
    'BOM の後からデータをコピー
    outStream.CopyTo csvStream
 
    '==============================
    ' ストリームのデータを書き出す
    '==============================
 
    Dim fileName As String
    fileName = ThisWorkbook.Path + "/" + ActiveSheet.Name & ".csv"
 
    'ファイルに保存
    csvStream.SaveToFile fileName, adSaveCreateOverWrite
 
    'ストリームの後始末
    csvStream.Close
    outStream.Close
 
End Sub
 
 
Sub SaveAsCSVForMac()
 
    Dim fileName As String
    Dim fileNo As Integer
 
    '==============================
    ' 使用しているデータ範囲の取得
    '==============================
    Dim maxRow As Long
    Dim startRow As Long
    Dim maxCol As Long
    Dim startCol As Long
 
    '検索対象のセル
    Dim CsvTop As Range
    Dim CsvRight As Range
    Dim CsvButtom As Range
 
 
    'セルの検索
    Set CsvTop = Range("A1:CZ2048").Find(What:="CSV_TOP", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    Set CsvRight = Range("A1:CZ2048").Find(What:="CSV_RIGHT", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    Set CsvButtom = Range("A1:CZ2048").Find(What:="CSV_BUTTOM", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
 
   'セルが見つかったかチェック
    If (CsvTop Is Nothing And CsvRight Is Nothing And CsvButtom Is Nothing) Then
        MsgBox "出力失敗 セルに CsvTop, CsvRight, CsvButtomの記述がありません"
    End If
 
    startRow = CsvTop.Row + 1
    maxRow = CsvButtom.Row - 1
    startCol = CsvTop.Column + 1
    maxCol = CsvRight.Column - 1
 
    fileNo = FreeFile
 
    fileName = ThisWorkbook.Path + "/" + ActiveSheet.Name & ".csv"
 
    Open fileName For Output As #fileNo
 
    Dim r As Long
    Dim c As Long
    Dim line As String
 
    '1 行ずつ処理
    For r = startRow To maxRow
 
        '1 列目はカンマなし
        line = ActiveSheet.Cells(r, startCol)
 
        '2 列目以降
        For c = startCol + 1 To maxCol
            line = line & "," & ActiveSheet.Cells(r, c)
        Next
 
        'r 行目のデータを StroutStre
        Print #fileNo, line
    Next
 
    Close #fileNo
 
End Sub