エクセルVBAでセル範囲のデータをクリップボードに

質問

セル範囲のデータをテキストとしてクリップボードに取り込みたいのです。

http://okwave.jp/qa/q5650002.html#16327676　の回答ANo2を見て

Sub test01()
Dim myData As DataObject
Dim myCb As Variant
Dim x
x = "TESTデータです。"
Set myData = New DataObject
myData.SetText x
myCb = myData.GetText
myData.PutInClipboard
End Sub

は出来ました。
そこで、セル範囲A1:B3をクリップボードに貼ろうといろいろやってみました。
一応、下記でできましたが、実際にはもっと広い範囲を取り込みたいので、もっと簡単な方法はないでしょうか？

Sub Clip()
Dim myStr As String
Dim myData As DataObject
Dim myCb As Variant
Set myData = New DataObject
With Sheets(1)
myStr = .Range("A1").Value & ":" & .Range("B1").Value & _
vbNewLine & .Range("A2").Value & ":" & .Range("B2").Value & _
vbNewLine & .Range("A3").Value & ":" & .Range("B3").Value
End With
myData.SetText myStr ', 1
myCb = myData.GetText

If MsgBox("データ" & vbNewLine & myCb & " をクリップボードに送りますか？ ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub

回答No.5

end-u · ベストアンサー

横いりすみません。

必要範囲をCoryしたら、
DataObjectのGetFromClipboardメソッドを使ってクリップボードデータを取得します。
そこからさらにDataObjectのGetTextメソッドを使うとテキスト文字列だけ取り出せます。
その後、DataObjectをClearして
あらためて取り出したテキスト文字列をSetTextすれば良いです。
各メソッドについては、DataObjectのヘルプを見て下さい。

ただし、OutlookならCtrl+VまでVBAでやれば良い気がしますが。
http://outlooklab.wordpress.com/
この辺りを参考にしてみると良いかと。
Sub try()
　　Const olFolderInbox As Long = 6
　　Const olMailItem As Long = 0
　　Dim obj As Object
　　Dim ins As Object
　　Dim m　 As Object
　　Dim tmp As String

　　If TypeName(Selection) <> "Range" Then Exit Sub

　　Selection.Copy
　　With New DataObject
　　　　.GetFromClipboard
　　　　tmp = .GetText
　　　　.Clear
　　End With
　　Application.CutCopyMode = False

　　On Error Resume Next
　　Set obj = GetObject(, "Outlook.Application")
　　On Error GoTo 0
　　If obj Is Nothing Then
　　　　Set obj = CreateObject("Outlook.Application")
　　　　obj.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Display
　　End If

　　For Each ins In obj.Inspectors
　　　　With ins.CurrentItem
　　　　　　If .MessageClass = "IPM.Note" Then
　　　　　　　　If Not .Sent Then
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　End If
　　　　End With
　　Next

　　If ins Is Nothing Then
　　　　Set m = obj.CreateItem(olMailItem)
　　Else
　　　　Set m = ins.CurrentItem
　　　　Set ins = Nothing
　　End If

　　m.body = tmp
　　m.Display

　　Set m = Nothing
　　Set obj = Nothing
End Sub

お礼

ほんとうにお世話になりました。
ありがとうございます。

回答No.8

mitarashi

#3です。ちょっと悪のり？
xl2010の場合、クリップボードに何が収納されるか調べてみました。
当たり前ですが、XML形式が増えて、Lotus123の形式が無くなって、Bifも極端に古いのは無くなっておりますね。
そこから先の形式には差が無いようですが、どんなものかは存じません。ご参考まで。
なお、今回はxl2010でレタッチしてみました。トリミングが面倒！トーンカーブは無さそう．．．

お礼

なんどもありがとうございます。
勉強します。

回答No.7

mitarashi

#3です。何故か盛り上がっていますね。
一つ思いついてしまいました。UserFormに、テキストボックスと、コマンドボタンを一個置きます。
UserForm1をモードレスで表示させ、セルを選択してコマンドボタンを押すと、テキストボックスや、単独セル内に貼り付けられる形で文字列がクリップボードにコピーされますので、質問者様のなさりたい事が出来ているのではと思います。
UserForm1のコードは下記だけです。ご参考まで。

Private Sub CommandButton1_Click()
Selection.Copy
With Me.TextBox1
.Paste
.SetFocus
.SelStart = 0
.SelLength = Len(Me.TextBox1)
.Copy
End With
End Sub

Private Sub UserForm_Initialize()
Me.TextBox1.MultiLine = True
End Sub

お礼

ありがとうございます。
勉強になります。

回答No.6

end-u

げっ
>必要範囲をCoryしたら、
必要範囲をCopyしたら、
..です...orz

お礼

ありがとうございます。

回答No.4

nicotinism

こんな感じじゃ？

Sub てすと()
　　Dim rC As Long, rR As Long
　　Dim strT As String
　　Dim myStr As String
　　Dim myData As DataObject
　　'Dim myCb As Variant

　　Set myData = New DataObject

　　Range("A1:D10").Select 'か適当に選択しておいて

　　For rR = 1 To Selection.Rows.Count
　　　　For rC = 1 To Selection.Columns.Count
　　　　　　strT = strT & vbTab & Selection(1).Offset(rR - 1, rC - 1)
　　　　Next rC
　　　　strT = Mid(strT, 2)
　　　　myStr = myStr & vbCrLf & strT
　　　　strT = ""
　　Next rR
　　myStr = Mid(myStr, 3)

　　myData.SetText myStr ', 1
　　'myCb = myData.GetText

　　If MsgBox("データ" & vbNewLine & myStr & " をクリップボードに送りますか？ ", vbYesNo + vbQuestion, "確認") = vbNo Then
　　　　Exit Sub
　　End If
　　myData.PutInClipboard
End Sub

お礼

ありがとうございます。
思った通りの動きです。
お礼が遅くなり、大変申し訳ございません。
いろいろなトラブルがあり、このサイトを見に来れませんでした。

回答No.3

mitarashi

添付図はxl2000の例ですが、セルをクリップボードにコピーすると、ここに上がっている全ての形式で格納される事になります。
RangeObjectだけで貼り付けられる訳ではありません。テキストの他にも、画像形式とか色々ありますね。例えばBiff?というのは、2003までのエクセルネイティブなデータ構造です。
なお、２列表示の図にする際に、clipbrd.exeで表示できない、グレー表示されている形式の部分は見難いので少し濃い色に変えてあります。

さて本題ですが、Range("A1:C3").Copyを実行後に、テキストエディターに貼り付けると、TAB区切りで貼り付けられます。
emaxemax様が、Outlookに貼り付けるときに期待した姿にならないとすると、Outlook側の問題だと思います。

お礼

ありがとうございます。
思った通りの動きです。
お礼が遅くなり、大変申し訳ございません。
いろいろなトラブルがあり、このサイトを見に来れませんでした。

補足

すみません、ほかの回答へのお礼を間違えて書いてしまいました。

回答No.2

kybo

>AとB列のテキストをコロンで結んだのは、それしかやりようがなかったからそうしましたが、本当はTabキーを打ったようにしたいのです。

If C.Column = 1 Then 'C.Column = 1はＡ列の意味
myStr = myStr & vbNewLine & C.Value
Else
myStr = myStr & vbTab & C.Value
End If

と":"をvbTabにすればいいです。

>やはりループさせる方法しかないのでしょうか？

本当にあなたがしたいことが、どういうことなのかしりませんが、通常セルをコピーしてExcelのクリップボードに入れたいだけであれば、以下の1行で用が足せます。

Range("A1:B100").Copy

お礼

何度もありがとうございます。
やりたいことは、一番最初に書いたとおり、
セル範囲のデータをテキストとしてクリップボードに取り込みたいのです。

Range("A1:B100").Copy
では、テキストではなくRangeObjectが入ってしまいます。

Ctrl+VキーでOutlookメールの本文にテキストで貼り付けたいのです。

回答No.1

kybo

以下の様な感じでどうでしょうか

Sub Clip()
Dim myStr As String
Dim myData As DataObject
Dim myCb As Variant
Set myData = New DataObject
Dim C As Range
With Sheets(1)
For Each C In .Range("A1:B100")
If myStr = "" Then
myStr = C.Value
Else
If C.Column = 1 Then 'C.Column = 1はＡ列の意味
myStr = myStr & vbNewLine & C.Value
Else
myStr = myStr & ":" & C.Value
End If
End If
Next C
End With
myData.SetText myStr ', 1
myCb = myData.GetText
If MsgBox("データ" & vbNewLine & myCb & " をクリップボードに送りますか？ ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub

お礼

さっそくありがとうございます。
やはりループさせる方法しかないのでしょうか？
あと、AとB列のテキストをコロンで結んだのは、それしかやりようがなかったからそうしましたが、本当はTabキーを打ったようにしたいのです。
わがまま言ってすみません。
よろしくお願いします。