VBA コピペした値が繰り上げされる

Question

前提・実現したいこと

シートの部分をコピーして、新規でシートを作り、そこに貼り付け、そのシートをテキストファイルで出力するものを作っています。
現在、ある程度のものはできていますが、値が途中で繰り上げされてしまい、コピー元の値と変わってしまっています。
VBA初心者なのでどこを直せばいいかわかりません。
個人的にはこのどちらかに原因がありそうかなと思っています。
・コピー元の値は他のセルに入っている値を参照しています（例：＝j145）
・貼り付け部分の書式がいくつかあったと思うのでそこを変えれば解決するのか

発生している問題・エラーメッセージ

値の繰り上げ例
例：
# aaa (mm)				                      # aaa (mm)	
2241.105973	0	3928.51553		→         2241.106	0	3928.516

該当のソースコード

Sub txt_出力()


    Sheets("■").Select
    Range("G4") = "STD"
    Range("H4") = "STD"
    Range("I4") = "STD"
    Application.ScreenUpdating = False
    'コピー元の選択
    Range("A15:E1163").Select
    Selection.Copy

    '追加したシートに名前を付ける
    Dim ws As Worksheet
    Set ws = Worksheets.Add
    ws.Name = "a"
       
    'コピー元を新シートに貼り付け
    Range("A1").Select
    Range("A1").PasteSpecial paste:=xlPasteValues

    Dim rUsed       As Range                '// UsedRange
    Dim r           As Range                '// Cell
    Dim fs          As New FileSystemObject '// FileSystemObject
    Dim ts          As TextStream           '// TextStream
    Dim sFilePath                           '// 出力ファイルパス
    Dim iRow                                '// 現在行
    Dim s                                   '// 出力文字列
    
    '// ファイルパス＝ブックと同じフォルダ＋シート名＋.txt
    sFilePath = ActiveWorkbook.Path & "\test.txt"
    
    '// FileSystemObjectで新規ファイル作成
    Set ts = fs.CreateTextFile(sFilePath, True, False)
    
    '// シートの入力範囲の全セルを取得
    Set rUsed = ActiveSheet.UsedRange
    
    iRow = 0
    
    '// 1セルずつループ
    For Each r In rUsed
        If iRow <> r.Row Then
            '// ループ初回時ではない場合
            If r.Row <> rUsed.Row Or r.Column <> rUsed.Column Then
                '// 行が変わったため改行コードを付与
                s = s & vbCrLf
            End If
            
            '// 行の先頭値を連結
            s = s & r.Text
        Else
            '// タブ文字区切りで連結
            s = s & vbTab & r.Text
        End If
        
        '// 現在行取得
        iRow = r.Row
    Next
    
    '// セルの文字列が存在する場合
    If s <> "" Then
        Call ts.WriteLine(s)
'        Call ts.Write(s)
'        Call ts.Write(vbCrLf)
    End If
    
    '// ファイルClose
    Call ts.Close
    
    'シートの削除
    Application.DisplayAlerts = False ' メッセージを非表示
    Worksheets("a").Delete
    Application.DisplayAlerts = True  ' メッセージを表示
    Application.ScreenUpdating = True
End sub

試したこと

補足情報（FW/ツールのバージョンなど）

Answer 1

とりあえず、原因として 2 つ思い当たりました。

---

①表示形式の問題

コピー元のセルに例えば「2241.105973」と表示されているのであれば、そのセルの表示形式は「標準」ではないものになっているかもしれません。「0.000000」とか？

Range("A1").PasteSpecial paste:=xlPasteValues

しかし、上記コードだと値しかコピーしていませんので、コピー先のセルの表示形式が仮に「0.000000」以外になっているなら、表示が意図しないものになってしまう可能性があります。

ということで、値だけコピーするのではなく表示形式も含めてコピーすればよいのではないでしょうか。

Range("A1").PasteSpecial paste:=xlPasteValues
↓
Range("A1").PasteSpecial paste:=xlPasteAll

---

②列幅の問題

あるいは、セルの幅（というか列の幅）が問題なのかもしれません。コピー先のセルの幅が、「2241.105973」全体を表示するのに十分な幅をもっていないことにより、表示できるだけの表示になってしまい、「2241.106」となっているのかもしれません。
だとすると、コピーした後に列幅も変えてあげるとよさそうです。

Answer 2

コピペで値が変わる、のではなく、コピペしたものの表示が変わる、です。

セルの書式が変わると表示が変わるのは当たり前です。そこらへんよく確認しましょう