'ワークシートをCSV形式("付き)で保存するマクロ5

'空白セルも含め、すべての値を""で囲みます。"は""に置換されます。
'セル値の編集にはTEXT関数とデータ範囲の1行目の表示形式を使います。
'ただし、文字列値はそのまま出力します。
'TEXT関数はすべての表示形式には対応していません。

'ワークシートを選択してMySaveAsCSV5マクロを実行してください。

Option Explicit

Sub MySaveAsCSV5()
    Const myTitle As String = "CSV形式(""付き)で保存"
    Dim oApp As Object
    Dim sFormats() As String
    Dim sDefault As String
    Dim sErrorDescription As String
    Dim iRowCount As Long
    Dim iColumnCount As Long
    Dim iHeaderRowCount As Long
    Dim vFileName As Variant
    Dim oRange_Input As Range
    Dim iRet As Long
    Dim i As Long

    On Error GoTo ErrorHandler

    Set oApp = Application
    oApp.StatusBar = False

    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "ワークシートを選択して実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    If TypeName(Selection) = "Range" Then
        With Selection
            If .Cells.Count = 1 Then .CurrentRegion.Select
        End With
        sDefault = Selection.Address
    Else
        sDefault = ""
    End If

    '対象範囲の選択
    Do While True
        Set oRange_Input = InputBoxRange( _
            "保存する範囲を選択してください。", myTitle, sDefault)
        If oRange_Input Is Nothing Then Exit Sub
        If oRange_Input.Areas.Count <> 1 Then
            MsgBox "連続していない範囲に対しては実行できません。", _
                vbExclamation, myTitle
        ElseIf (oRange_Input.Worksheet.Name <> ActiveSheet.Name) Or _
                (oRange_Input.Worksheet.Parent.Name <> ActiveWorkbook.Name) Then
            MsgBox "アクティブシート以外の範囲に対しては実行できません。", _
                vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

    oRange_Input.Select

    iRowCount = oRange_Input.Rows.Count
    iColumnCount = oRange_Input.Columns.Count
    iHeaderRowCount = 0

    If iRowCount > 1 Then

        '1行目の出力の確認
        iRet = MsgBox("1行目を範囲から除きますか?", _
            vbQuestion Or vbYesNoCancel, myTitle)
        If iRet = vbCancel Then
            Exit Sub
        ElseIf iRet = vbYes Then

            '1行目を除いた範囲を取得
            iRowCount = iRowCount - 1
            Set oRange_Input = oRange_Input.Resize(iRowCount).Offset(1)
            oRange_Input.Select

        Else

            '1行目を見出し行とするか確認
            iRet = MsgBox("現在の選択範囲の2行目の表示形式を使用しますか?", _
                vbQuestion Or vbYesNoCancel, myTitle)
            If iRet = vbCancel Then
                Exit Sub
            ElseIf iRet = vbYes Then
                iHeaderRowCount = 1
            End If
        End If
    End If

    'データ範囲の1行目を使って表示形式の配列を作成
    ReDim sFormats(1 To oRange_Input.Columns.Count)
    For i = 1 To iColumnCount
        sFormats(i) = oRange_Input.Cells(iHeaderRowCount + 1, i).NumberFormatLocal
    Next

    If MyVal(Application.Version) >= 8 Then
        For i = 1 To iColumnCount
            sFormats(i) = NumberFormatConv(sFormats(i))
        Next
    End If

    'ファイル名の入力
    vFileName = Application.GetSaveAsFilename( _
        initialFilename:=ActiveSheet.Name & ".txt", _
        fileFilter:=StrConv("テキスト ファイル (*.txt), *.txt," & _
        "すべてのファイル (*.*), *.*", vbNarrow), _
        filterIndex:=1, title:=myTitle)
    If VarType(vFileName) = vbBoolean Then Exit Sub

    '上書きの確認
    If Dir$(vFileName) <> "" Then
        If MsgBox(vFileName & " はすでに存在します。" & Chr$(10) _
            & "上書きしますか？", vbOKCancel Or vbExclamation, _
            myTitle) <> vbOK Then Exit Sub
    End If

    '使用範囲をCSV形式(""付き)で保存する
    iRet = MyWriteCSV(oRange_Input, CStr(vFileName), sFormats(), _
        sErrorDescription, 8000)

    oApp.StatusBar = False

    If iRet = 0 Then
        MsgBox vFileName & " へCSVデータを出力しました。", vbInformation, myTitle
    Else
        MsgBox sErrorDescription & " (" & iRet & ")", vbExclamation, myTitle
    End If

    Exit Sub

ErrorHandler:
    oApp.StatusBar = False
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub

'セル範囲を入力する関数
Function InputBoxRange(prompt As String, title As String, _
        default As String) As Range
    On Error Resume Next
    Set InputBoxRange = Application.InputBox( _
        prompt:=prompt, title:=title, default:=default, Type:=8)
End Function

Function MyVal(ByVal sNumber As String) As Double
    Dim bPoint As Boolean
    Dim i As Integer
    bPoint = False
    For i = 1 To Len(sNumber)
        Select Case Mid$(sNumber, i, 1)
            Case "0" To "9"
            Case "."
                If bPoint Then
                    Exit For
                Else
                    bPoint = True
                End If
            Case Else
                Exit For
        End Select
    Next
    If i > 1 Then
        MyVal = CDbl(Left$(sNumber, i - 1))
    Else
        MyVal = 0
    End If
End Function
'表示形式の"G/標準"や"[赤]"などを変換する関数
Function NumberFormatConv(sFormat As String) As String
    Dim sChar As String, sResult As String
    Dim i As Long, j As Long, n As Long
    sResult = ""
    n = Len(sFormat)
    i = 1
    Do While i <= n
        sChar = Mid$(sFormat, i, 1)
        Select Case sChar
            Case """"
                j = InStr(i + 1, sFormat, """", 0)
                If j = 0 Then
                    sResult = sResult & Mid$(sFormat, i)
                    Exit Do
                Else
                    sResult = sResult & Mid$(sFormat, i, j - i + 1)
                    i = j + 1
                End If
            Case "!"
                sResult = sResult & Mid$(sFormat, i, 2)
                i = i + 2
            Case "["
                Select Case Mid$(sFormat, i + 1, 2)
                    Case "黒]"
                        sResult = sResult & "[Black]"
                        i = i + 3
                    Case "青]"
                        sResult = sResult & "[Blue]"
                        i = i + 3
                    Case "水]"
                        sResult = sResult & "[Cyan]"
                        i = i + 3
                    Case "緑]"
                        sResult = sResult & "[Green]"
                        i = i + 3
                    Case "紫]"
                        sResult = sResult & "[Magenta]"
                        i = i + 3
                    Case "赤]"
                        sResult = sResult & "[Red]"
                        i = i + 3
                    Case "白]"
                        sResult = sResult & "[White]"
                        i = i + 3
                    Case "黄]"
                        sResult = sResult & "[Yellow]"
                        i = i + 3
                    Case Else
                        If Mid$(sFormat, i + 1, 1) = "色" Then
                            j = InStr(i + 2, sFormat, "]", 0)
                            If j = 0 Then
                                sResult = sResult & Mid$(sFormat, i)
                                Exit Do
                            Else
                                sResult = sResult & "[Color" & _
                                    Mid$(sFormat, i + 2, j - i - 1)
                                i = j + 1
                            End If
                        Else
                            sResult = sResult & sChar
                            i = i + 1
                        End If
                End Select
            Case "G"
                If Mid$(sFormat, i + 1, 3) = "/標準" Then
                    sResult = sResult & "General"
                    i = i + 4
                Else
                    sResult = sResult & sChar
                    i = i + 1
                End If
            Case Else
                sResult = sResult & sChar
                i = i + 1
        End Select
    Loop
    NumberFormatConv = sResult
End Function


'セル範囲をファイル出力する関数
Function MyWriteCSV(ByVal oRange As Range, ByVal sFileName As String, _
        ByRef sFormats() As String, ByRef sErrorDescription As String, _
        ByVal iBufferSize As Long) As Long
    Dim sQT1 As String, sQT2 As String
    Dim sCRLF As String, sComma As String
    Dim oApp As Object
    Dim iFileNo As Long
    Dim iRowCount As Long
    Dim iColumnCount As Long
    Dim iBlockRow As Long, iBlockRowCount As Long
    Dim vRange As Variant
    Dim sBuffer As String, sLine As String
    Dim sField As String, sChar As String
    Dim r As Range
    Dim i As Long, j As Long, k As Long
    Dim v As Variant

    On Error GoTo ErrorHandler

    Set oApp = Application
    sQT1 = """"
    sQT2 = """"""
    sCRLF = Chr$(13) & Chr$(10)
    sComma = ","

    iRowCount = oRange.Rows.Count
    iColumnCount = oRange.Columns.Count
    iBlockRowCount = 2700 \ iColumnCount

    iFileNo = FreeFile()
    Open sFileName For Output Lock Read Write As iFileNo

    sBuffer = ""

    MyStatusBar -1

    For iBlockRow = 1 To iRowCount Step iBlockRowCount

        MyStatusBar Int((iBlockRow / iRowCount) * 10)

        If iBlockRow + iBlockRowCount >= iRowCount Then
            iBlockRowCount = iRowCount - iBlockRow + 1
        End If
        
        vRange = oRange.Rows(iBlockRow).Resize(iBlockRowCount)

        For i = 1 To iBlockRowCount

            'セル値の編集
            sLine = ""
            j = 1
            Do
                v = vRange(i, j)
                Select Case VarType(v)
                Case vbEmpty
                    sField = ""
                Case vbString
                    sField = v
                Case Else
                    sField = Trim$(oApp.Text(v, sFormats(j)))
                End Select

                sLine = sLine & sQT1

                For k = 1 To Len(sField)
                    sChar = Mid$(sField, k, 1)
                    If sChar = sQT1 Then
                        sLine = sLine & sQT2
                    Else
                        sLine = sLine & sChar
                    End If
                Next

                If j = iColumnCount Then
                    sLine = sLine & sQT1 & sCRLF
                    Exit Do
                End If

                sLine = sLine & sQT1 & sComma
                j = j + 1
            Loop

            'ファイル出力
            If LenB(sBuffer) + LenB(sLine) >= iBufferSize Then
                Print #iFileNo, sBuffer;
                sBuffer = sLine
            Else
                sBuffer = sBuffer & sLine
            End If
        Next
    Next

    If Len(sBuffer) > 0 Then Print #iFileNo, sBuffer;
    Close #iFileNo
    MyStatusBar 10
    MyWriteCSV = 0
    Exit Function

ErrorHandler:
    MyWriteCSV = Err
    sErrorDescription = Error(Err)
    If iFileNo <> 0 Then Close #iFileNo
    If Not (r Is Nothing) Then
        sErrorDescription = sErrorDescription & " at " & r.Row
    End If
End Function


Sub MyStatusBar(ByVal iArg As Integer)
    Static iCount As Integer

    If iArg < 0 Then
        iCount = 0
    Else
        If iArg = iCount Then Exit Sub
        If iArg > 10 Then iCount = 10 Else iCount = iArg
    End If

    Application.StatusBar = "処理中です... " _
        & Right$("  " & CStr(iCount * 10), 3) & "% " & _
        String$(iCount, Chr$(&H81A1)) & _
        String$(10 - iCount, Chr$(&H81A0))
End Sub