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