RのreadxlによるExcelファイルのデータ読み込み時の小数値の値変化の回避策 #Excel

小数を文字列として読み込むとExcel上で見えている数値から小さな値だけずれてしまうことがあるので, Excel書式を文字列としてから入力したファイルを用意する

Excelファイルにデータを保存して, それをRのreadxlやopenxlsxで読み込んで処理することがあるが, 一筋縄ではいかない... 以下はreadxlで確認した内容である. openxlsxの場合はまた別の問題も生じうる（書式のフォント設定とか）ので, 読み込みにはあまり使っていない.

環境

R: 3.6.2
readxl: version 1.3.1
Excel: office 365. 32bit. バージョン2007(ビルド13029.20308 Microsoft Store)

現象

例えばsample_data_X1.xlsxファイルにExcelのセルA3に書式:標準で, 342.3902という値を入力したとする. さらにB3セルの書式を文字列に変えてから, 342.3902という値を入力したとする. Excel上で直接セルを選択するといずれも342.3902と表示されている. このファイルをreadxlで読み込んで, 文字列として読み込むと, A3は 342.39019999999999となる(場合がある. B3は342.3902となる.

readxl::read_xlsx(path = "sample_data_X1.xlsx", col_types = "text", col_names = F)
New names:
* `` -> ...1
* `` -> ...2
# A tibble: 3 x 2
  ...1               ...2    
  <chr>              <chr>   
1 1.3                1.3     
2 60.1               60.1    
3 342.39019999999999 342.3902

※A1:B2にも比較用に値を入れてある.

ちなみに, 数値として読み込むと, 一見すると小数点以下が無視されるように見えるが, data.frameに変換したり直接値要素を表示すると, 342.3902として読み込めていることが確認できる.

readxl::read_xlsx(path = "sample_data_X1.xlsx", col_types = "numeric", col_names = F)

New names:
* `` -> ...1
* `` -> ...2
# A tibble: 3 x 2
   ...1  ...2
  <dbl> <dbl>
1   1.3   1.3
2  60.1  60.1
3 342.  342. 
 警告メッセージ: 
1:  read_fun(path = enc2native(normalizePath(path)), sheet_i = sheet,  で: 
  Coercing text to numeric in B1 / R1C2: '1.3'
2:  read_fun(path = enc2native(normalizePath(path)), sheet_i = sheet,  で: 
  Coercing text to numeric in B2 / R2C2: '60.1'
3:  read_fun(path = enc2native(normalizePath(path)), sheet_i = sheet,  で: 
  Coercing text to numeric in B3 / R3C2: '342.3902'

数値だけの列であれば数値として読み込めば特に問題はない.
文字列と数値が一列中に混在している場合は, 文字列として読み込むと, 意図しないずれが発生する場合があることになる.

対策

csvファイルとして出力してから, csvファイルを読み込む

Excel上でcsvとして保存しなおすと, Excel上で見えている342.3902のままcsvに出力されることをテキストエディタで確認できる.

但し, Excelファイルを直接読み込むことを諦めることになる. シートが多数あるとそれなりに面倒そうであるし,
セル範囲を指定して読み込むなどもできなくなる.
Excelファイルの書式を文字列としてから値を入力したファイルを読み込む

これなら問題なく読み込める.

但し, Excelファイルにデータを用意する際にはすべての書式が文字列になっていないだろう. 後から書式だけを文字列に変更しても効果はない（なかったはず）.
従って, 元のExcelファイルから, 書式を文字列に変えて再入力したExcelファイルを用意する必要がある.
手動でやるならば, 以下の手順で用意できる.
1. Excelファイルを開いて, 該当シートの該当範囲を選択しコピーして空のテキストファイルに貼り付け
  これでExcelファイル上での見た目のデータをテキストファイル上に退避できる.
2. Excelファイルのシートの書式を文字列に変更 (または新しいExcelファイルを作成して全範囲の書式を文字列としておく)
3. 開いているテキストファイルの範囲全体をコピーして, 2.のExcelシートに貼り付けて保存する.
複数シートある場合は当然ながら各シート毎に実施する必要がある.

いろいろググりながら2.の作業を自動化するVBAコードを書いてみた.
xlsmファイル上で実行するようにハードコードしてあったり, セル範囲に対する前提条件があるため, 要注意である.

Option Explicit


Sub CheckTempTextFile(filePath As String)
    Dim tempfile As String
    tempfile = filePath
    Dim ret As Variant

    If Dir(tempfile) <> "" Then
        ret = MsgBox(filePath & "が既に存在します. 上書きしますか", vbYesNo)
    Else
        ret = 6
    End If
    If ret <> 6 Then End

End Sub

Sub CopyToFile(wb As Workbook, sheetName As String, filePath As String)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wb.Worksheets(sheetName).Copy ' コピーすると生成してしまう
    ' これで意図通りかは要確認: double quote で囲まれてはいるが、いけそうか。 -> だめっぽい
    ' ActiveWorkbook.SaveAs FileName:=filePath, FileFormat:=xlText
    ' ActiveWorkbook.SaveAs FileName:=filePath, FileFormat:=xlCSV ' カンマ区切り. これもだめ.
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub SetCellFormat(wb As Workbook, sheetName As String)
    wb.Worksheets(sheetName).Cells.NumberFormatLocal = "@"
End Sub

Sub CopySheetToTextFile(sheet As Worksheet, filePath As String, rowSize As Integer, colSize As Integer)
    Application.ScreenUpdating = False
    Dim buf As String, bufArray As Variant, bufRow As Variant, n As Long, j As Long
    ReDim bufArray(rowSize, colSize)
    ' ここで1スタートに変わることに注意
    bufArray = Range(sheet.Cells(1, 1), sheet.Cells(rowSize, colSize)).Value ' sheetを指定しないと, 意図しないsheetを参照してしまう.
    Open filePath For Output As #1
        n = 0
        Do Until n = rowSize
            n = n + 1
            buf = ""
            For j = 1 To colSize
                buf = buf & bufArray(n, j) & Chr(9)
            Next j
            Print #1, buf
        Loop
    Close #1
    Application.ScreenUpdating = True
End Sub

Sub PasteTextFileToSheet(filePath As String, sheet As Worksheet, rowSize As Integer, colSize As Integer)
    Application.ScreenUpdating = False
    Dim buf As String, bufArray As Variant, bufRow As Variant, n As Long, j As Long
    ReDim bufArray(rowSize, colSize)
    Open filePath For Input As #1
        n = 0
        Do Until n = rowSize ' この書き方だと rowSizeまで.
            Line Input #1, buf
            bufRow = Split(buf, Chr(9)) ' tab
            'bufRow = Split(buf, ",")
            For j = 0 To colSize - 1
                bufArray(n, j) = bufRow(j)
            Next j
            n = n + 1
        Loop
    Close #1
    sheet.Range("A1").Resize(rowSize, colSize) = bufArray
    Application.ScreenUpdating = True
End Sub

Sub GetRegionShape(wb As Workbook, sheetName As String, ByRef rowCount As Integer, ByRef colCount As Integer)
    ' A1 sheet の current region のサイズを取得
    Dim ro As Range
    Set ro = wb.Worksheets(sheetName).Range("A1").CurrentRegion

    rowCount = ro.Rows.Count
    colCount = ro.Columns.Count
End Sub

Function JudgeAbsolutePathOrRelativePath(filePath As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim ret As String
    If filePath = "" Then
        ret = ""
    ElseIf filePath = FSO.GetAbsolutePathName(filePath) Then
        ret = "absolute"
    Else
        ret = "relative"
    End If
    JudgeAbsolutePathOrRelativePath = ret
End Function

Sub exec()
    Dim filePath As String
    filePath = ThisWorkbook.Path & "\tempfile.txt"
    Call CheckTempTextFile(filePath)

    Dim filePathWorkBook As String
    filePathWorkBook = ThisWorkbook.Worksheets("main").Range("B1").Value
    If filePathWorkBook = "" Then
        MsgBox "B1セルに加工対象workbookのファイルパスを入力して下さい"
        End
    ElseIf JudgeAbsolutePathOrRelativePath(filePathWorkBook) = "relative" Then
        filePathWorkBook = ThisWorkbook.Path & "\" & filePathWorkBook
    End If
    Dim dirpath As String
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    dirpath = FSO.GetParentFolderName(filePathWorkBook)

    Dim targetWorkBook As Workbook
    Set targetWorkBook = Workbooks.Open(filePathWorkBook)

    ' 各シートを対象とする
    Dim targetSheet As Worksheet, idxWorkSheet As Long
    For idxWorkSheet = 1 To targetWorkBook.Worksheets.Count
        Set targetSheet = targetWorkBook.Sheets(idxWorkSheet)

        Dim sheetName As String
        sheetName = targetSheet.Name
        Dim rowCount As Integer, colCount As Integer
        Call GetRegionShape(targetWorkBook, sheetName, rowCount, colCount)

        'Call CopyToFile(targetWorkBook, sheetName, filePath)
        Call CopySheetToTextFile(targetWorkBook.Worksheets(sheetName), filePath, rowCount, colCount)
        ' 書式設定
        Call SetCellFormat(targetWorkBook, sheetName)
        ' テキストファイルからのシートへの貼り付け: ここで改めて貼り付けることに意味がある
        Call PasteTextFileToSheet(filePath, targetWorkBook.Worksheets(sheetName), rowCount, colCount)
        ' tempfile を削除
        Kill filePath
    Next idxWorkSheet

    Dim newFilePathWorkbook As String
    newFilePathWorkbook = ThisWorkbook.Worksheets("main").Range("B2").Value
    If newFilePathWorkbook = "" Then
        newFilePathWorkbook = dirpath & "\" & "new.xlsx"
    ElseIf JudgeAbsolutePathOrRelativePath(newFilePathWorkbook) = "relative" Then
        newFilePathWorkbook = dirpath & "\" & newFilePathWorkbook
    End If
    targetWorkBook.SaveAs newFilePathWorkbook
    targetWorkBook.Close
    MsgBox "Done!"
End Sub

Rからreadxlを呼ぶ前に実行すれば, 手作業を挟まずに処理を連続的に実行できるようになる.
RからVBAを呼ぶにはどうすればばよいか. 以下を見ると, RDCOMClient を使えばよいらしい.

参考

https://github.com/tidyverse/readxl/issues/360