DataObject

セルの値だけコピーするやり方として、DataObjectを使ったやり方があります。


Sub ValueCopy1()
    With New DataObject
        .SetText ActiveCell
        .PutInClipboard
    End With
End Sub

しかし、このやり方ですとうまくコピーできない時があります。
私の場合、「・・」になってたり、形式をテキストにして貼り付けすると「？？」になったりします。

別のやり方として、テキストボックスを使ってコピーする方法があります。

TextBox.Copy

Sub Main()
    Call ValueCopy2(ActiveCell)
End Sub

Sub ValueCopy2(value As String)
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = value
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
  End With
End Sub

結果

うまくコピーできました。
ただ、この場合、1つのセルしかコピーできないので、もう少し工夫します。

選択したセル全ての値をコピー


Sub Main()
    Call ValueCopy(SelectionCellsValue(Selection))
End Sub

Function SelectionCellsValue(ra As Range) As String
    Dim count As Integer: count = ra.Row
    Dim first As Boolean: first = True
    Dim r As Range
    Dim value As String
    For Each r In ra
        If first Then
            value = r.value
            first = False
        ElseIf r.Row = count Then
            value = value & vbTab & r.value 'vbTabは半角スペースでもいいかも(お好みで)
        Else
            value = value & vbCrLf & r.value
            count = count + 1
        End If
    Next r
    SelectionCellsValue = value
End Function

Sub ValueCopy3(value As String)
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = value
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
  End With
End Sub

結果

選択した範囲全てコピーできました。
後はMainをショートカットキー Ctrl + Shift + Cなどに割り当てると便利です。

参考サイト

[VBA]DataObjectを使ったクリップボード操作が上手くいかない場合の対処法

追記

↑えっなんでこんな長ったらしいの？firstいる？
気に入らなかったので書き直しました。

Sub CellsValueCopy()
    Dim row As Integer: row = ActiveCell.row
    Dim rng As Range
    Dim value As String
    For Each rng In Selection
        If rng.row = row Then
            value = value & rng.value & " "
        Else
            value = Left(value, Len(value) - 1) & vbCrLf & rng.value & " "
            row = rng.row
        End If
    Next rng
    Call ValueCopy(Left(value, Len(value) - 1))
End Sub