<Array to CSV> 「配列」を「CSV」へ。Excelで保存。指数表示対策済み。

以下のマクロを使用していて、問題が発生しました。

<Array to CSV> 「配列」を「CSV」へ。Excelで保存。高速処理。

以下のようなシートを、配列に入れ、CSVファイルに入れるマクロです。ここで、B4セルに注目してください。中身は、「100000000000」ですが、セルには「1E+11」と指数表示となっています。12桁以上になると、指数表示なるようです。

配列に入れるまでは、以下の通り問題ありません。

このまま、CSV形式で保存すると、以下の通り、指数表示のまま、保管されてしまいます。

これを回避するための、マクロが、以下です。

Dim arr() As Variant

Private Sub test､シートを配列に入れ､csvファイルに出力()
    ' (ws, ByRef arr, Optional RejectRw = 0)
    Call sheet_to_array("TEST", arr)
    ' (ByRef arr, FileName, Optional 種類)
    Call array_to_csv_Excel(arr, ThisWorkbook.Path & "\sample5.csv")
End Sub


'*******
'* 二次元配列をCSVファイルに出力、高速化。20230912
'* https://excel-vba.work/2021/01/03/%E3%80%90vba%E3%80%91%E6%8C%87%E5%AE%9A%E3%81%97%E3%81%9F%E7%AF%84%E5%9B%B2%E3%82%92csv%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%81%B8%E5%87%BA%E5%8A%9B%E3%81%99%E3%82%8B/
'* arr：二次元配列。これが、csvファイルに出力される
'* FileName：csvファイル名、フルパス
Private Sub array_to_csv_Excel(ByRef arr As Variant, ByVal FileName As String)
    Dim csvFile As String
    ' Dim targetRange As Range
    Dim wb As Workbook
    Dim fso As Object
    
    '出力するCSVファイルを指定
    csvFile = FileName
    
    'CSVファイルへ出力する範囲を指定 ※例としてシート「sample」のセル「B2」から続く一連の範囲を指定
    'Set targetRange = Worksheets("sample").Range("B2").CurrentRegion
    'Set targetRange = arr
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '出力するCSVファイルが既に存在する場合は削除
    If fso.FileExists(csvFile) Then
    
        If IsBookOpened(csvFile) Then
            Dim rc As Integer
            rc = MsgBox("ファイルが開いています。" & vbCrLf & _
                "はい：閉じて、削除して、処理を続けます。" & vbCrLf & _
                "いいえ：処理を中断します", vbYesNo + vbQuestion, "確認")
            If rc = vbYes Then
                Dim FileNameOnly As String
                FileNameOnly = fso.GetFileName(csvFile)
                Windows(FileNameOnly).Close
                
            Else
                End
            End If
        End If
        ' ファイル削除
        fso.DeleteFile csvFile
    End If
    
    '新規ブックを作成
    Set wb = Workbooks.Add
    
    ' 配列をブックにコピー
    ' wb.Worksheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr    この行は削除


    ' =======================================================以下が今回追加
    
    ' 配列をブックにコピー
    Dim ws As Worksheet
    Set ws = wb.Worksheets(1)
    ws.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr


    ' 1列目全体の表示形式を文字列にするオブジェクト式
    ws.Columns(1).NumberFormatLocal = "@"
    
    ' 指数表示から文字列に変換
    Dim rw As Long
    For rw = 2 To UBound(arr)
        Cells(rw, 1).Value = Format(Cells(rw, 1))
    Next rw
    ' =======================================================ここまでが今回追加



    '新規ブックをCSVファイルとして出力
    wb.SaveAs FileName:=csvFile, FileFormat:=xlCSV, Local:=True
    ' 「xlCSV」・・・・・文字コードは「Shift_JIS」となります。
    ' 「Local:=」に「True」を指定することで、「日付の形式」を「Excelの言語設定で指定されている言語(日本語と思います)」にします
    
    '新規ブックを保存せずに閉じる
    wb.Close SaveChanges:=False
    
    '後片付け
    Set fso = Nothing

End Sub

'*******
'* 「シート」を「配列」に入れるプロシージャ。20230707
'* SheetName：シート名前
'* myArray：出力される配列は、参照渡し。配列は、モジュールレベル変数としている。
'* RejectRw=1とすると頭の1行目を除いた表が、配列に入る。1行目の見出しが不要な場合に使用。
Sub sheet_to_array(ByVal SheetName As String, ByRef myArray As Variant, Optional RejectRw As Long = 0)
    ' 表を一気に変数にいれて処理
    Dim Target As Range
    
    Set Target = Worksheets(SheetName).UsedRange
    
    With Target
        If .Rows.Count > RejectRw And RejectRw > 0 Then
            ' 最初の行数（RejectRw）を除外する
            Set Target = .Resize(.Rows.Count - RejectRw).Offset(RejectRw)
        End If
    End With
    
    'Variant型の変数に値を一気に代入する
    myArray = Target.Value
End Sub

Public Function IsBookOpened(ByVal FilePath As String) As Boolean
    On Error Resume Next
    
    Open FilePath For Append As #1
    Close #1
    
    If Err.Number > 0 Then
        IsBookOpened = True
    Else
        IsBookOpened = False
    End If
End Function

CSV形式で保管する直前のExcelが以下です。

以下のマクロで、Ａ列の表示型式をを文字列に設定して、A列の値をセルごとに指数表示から文字列に変換しています。それで、無事、指数表示から文字列に変換されました。

    ' 1列目全体の表示形式を文字列にするオブジェクト式
    ws.Columns(1).NumberFormatLocal = "@"
    
    ' 指数表示から文字列に変換
    Dim rw As Long
    For rw = 2 To UBound(arr)
        Cells(rw, 1).Value = Format(Cells(rw, 1))
    Next rw

CSVファイルも、以下の通り、問題なく作成されました。

12桁以上の数字を使用するときは、注意が必要です。

上のマクロは、1列目だけの対応ですが、以下は、すべてのセルを対象に、文字列を表す「’」を、配列データに追加して、その後、セルに書き込んでいます。このようにすると、どのセルも、文字列になるので、指数表示の問題は起きません。

'*******
'* 二次元配列をCSVファイルに出力、高速化。20230912
'* すべての列に対して指数表示対応。20241114
'* https://excel-vba.work/2021/01/03/%E3%80%90vba%E3%80%91%E6%8C%87%E5%AE%9A%E3%81%97%E3%81%9F%E7%AF%84%E5%9B%B2%E3%82%92csv%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%81%B8%E5%87%BA%E5%8A%9B%E3%81%99%E3%82%8B/
'* arr：二次元配列。これが、csvファイルに出力される
'* FileName：csvファイル名、フルパス
Private Sub array_to_csv_Excel_r1(ByRef arr As Variant, ByVal fileName As String)
    Dim csvFile As String
    Dim wb As Workbook
    Dim fso As Object
    
    '出力するCSVファイルを指定
    csvFile = fileName
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '出力するCSVファイルが既に存在する場合は削除
    If fso.FileExists(csvFile) Then
        If IsBookOpened(csvFile) Then
            Dim rc As Integer
            rc = MsgBox("ファイルが開いています。" & vbCrLf & _
                "はい：閉じて、削除して、処理を続けます。" & vbCrLf & _
                "いいえ：処理を中断します", vbYesNo + vbQuestion, "確認")
            If rc = vbYes Then
                Dim FileNameOnly As String
                FileNameOnly = fso.GetFileName(csvFile)
                Windows(FileNameOnly).Close
            Else
                End
            End If
        End If
        ' ファイル削除
        fso.DeleteFile csvFile
    End If
    
    '新規ブックを作成
    Set wb = Workbooks.Add
    
    ' =======================================================以下が今回追加
    
    ' 新しい配列を作成して、全ての要素を文字列（頭に「'」追加）に変換
    Dim i As Long, j As Long
    Dim newArr As Variant
    ReDim newArr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            newArr(i, j) = "'" & CStr(arr(i, j))
        Next j
    Next i

    ' 新しい配列をブックにコピー
    wb.Worksheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = newArr

    ' =======================================================ここまでが今回追加
    
    '新規ブックをCSVファイルとして出力
    wb.SaveAs fileName:=csvFile, FileFormat:=xlCSV, Local:=True
    ' 「xlCSV」・・・・・文字コードは「Shift_JIS」となります。
    ' 「Local:=」に「True」を指定することで、「日付の形式」を「Excelの言語設定で指定されている言語(日本語と思います)」にします
    
    '新規ブックを保存せずに閉じる
    wb.Close SaveChanges:=False
    
    '後片付け
    Set fso = Nothing

End Sub

Follow me!