Excel VBA セルの値だけコピー

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を使ったクリップボード操作が上手くいかない場合の対処法

追記 2026/02/06

このコード、未だに使うんでAIに要望を言って改良してもらいました。
結合セルでもちゃんとコピーできるよう指示しました、便利。

Sub CellsValueCopy()
    Dim row As Integer: row = ActiveCell.row
    Dim rng As Range
    Dim value As String
    
    For Each rng In Selection.Cells
        If rng.MergeCells Then
            ' 結合セルは左上セルのみ取得(重複防止)
            If rng.Address <> rng.MergeArea.Cells(1).Address Then
                GoTo continue
            End If
        End If
        
        ' 行が変わったら改行(直前行の末尾スペースだけ削る)
        If rng.row = row Then
            value = value & CStr(rng.value) & " "
        Else
            ' 不要削除防止：RTrim$で末尾スペースのみ除去
            value = RTrim$(value)
            value = value & vbCrLf & CStr(rng.value) & " "
            row = rng.row
        End If
        
continue:
    Next rng
    
    Call ValueCopy(Left$(value, Len(value) - 1))
End Sub    

過去のしょうもない追記

追記

↑えっなんでこんな長ったらしいの？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