[VBA][Excel]クリップボードからフィールドを区切って貼り付けるマクロ

すでにクリップボードにあるテキストデータを、スペースを区切り文字（連続した区切り文字は1文字として扱う）として貼り付けるマクロが作りたいです。
どうか教えてください。

質問者からの補足コメント

• A1に貼り付けたいです。
  「あい˽うえお˽˽ かきく˽ けこ
  さし すせそ」
  の場合は 、A1「あい」 B1「うえお」 C1「かきく」 D1「けこ」
  A2「さし」B2「すせそ」
  となるようにしたいです。

    補足日時：2016/08/16 19:30

• 

  テキストを貼り付け後、「テキストファイルウィザードを使用（U)...」というのを使っているのですが、この動作をマクロ化したいです。最初からこのように書くべきだったかもしれません。
  
  テキストファイルウィザードの設定は区切り文字をスペースにして、あとは添付の画像の様に設定しています。

  
    補足日時：2016/08/17 11:39

No.1 回答者： GooUserラック 回答日時： 2016/08/16 19:04

どこにどのように貼り付けるのでしょうか？

たとえば
① 選択されているセルから右に向かって貼り付ける。
② 選択されているセルから下に向かって貼り付ける。
③ その他

また①だとした時に選択したセルがA1でクリップボードの内容が「あい˽うえお˽˽かきく˽けこ」の場合は 、（「˽」は空白１文字）
A1「あい」
B1「うえお˽かきく」
C1「けこ」
で良いのでしょうか？

この回答へのお礼

ご質問ありがとうございました。
捕捉に回答を追記いたしました。分かりにくい場合はまたコメント頂ければと思います。

お礼日時：2016/08/16 19:33

No.2 回答者： WindFaller 回答日時： 2016/08/16 21:49

>スペースを区切り文字（連続した区切り文字は1文字として扱う）

今のところ、区切り文字は、スペース(半角・全角）になっています。
区切りは、Split を使っています。複合的な区切りなどの場合は、
正規表現Split (BRegExp) を使ったほうがよいでしょうね。

これは、ショートカットをつけると便利だと思います。
'//
Sub OutputfmrClipboard()
　Dim CB As Object
　Dim buf As Variant
　Dim arbuf As Variant
　Dim i As Long, j As Long, k As Long, n As Long
　Const CLSID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
　
　Set CB = CreateObject("new:" & CLSID)
　On Error GoTo ErrHandler
　With CB
　　.GetFromClipboard
　　buf = .GetText
　　If VarType(buf) = vbString Then
　　　buf = Replace(buf, Space(1), Space(1), , , vbTextCompare)
　　　Do
　　　　buf = Replace(buf, Space(2), Space(1), , , vbTextCompare)
　　　Loop Until InStr(buf, Space(2)) = 0
　　　arbuf = Split(buf, Space(1))
　　　j = UBound(arbuf)
　　　If j > -1 Then
　　　　For k = 0 To Int(j / 4)
　　　　　For i = 0 To 3
　　　　　　ActiveCell.Offset(k, i).Value = Application.Clean(arbuf(n))
　　　　　　n = n + 1
　　　　　　If n > j Then Exit For
　　　　　Next i
　　　　Next k
　　　Else
　　　　ActiveCell.Value = Trim(arbuf)
　　　End If
　　End If
　End With
ErrHandler:
　Set CB = Nothing
　If Err() <> 0 Then
　　MsgBox Err.Number & " :" & Err.Description
　End If
End Sub

'//

とりあえず試してみてください。おかしな部分があるかもしれません。以前、同様の回答で、不満を感じる人がいたようですが、これ以上のもの(様々なフォーマットを扱うクリップボード）を望まれると、掲示板の域を超えてしまうことになると思います。

上記でClean 関数を使っています。理由は、なぜか改行コードあたりが紛れ込むようです。

簡単に行うなら、区切り位置を利用して、ダミーを使って覚えさせれば、同じようなことが可能です。

この回答へのお礼

素晴らしいです。素早い回答もうれしかったです。

ただ、私の説明が悪かったですね。
テキストに改行があったとき次の行の1列目から貼り付けたいのです。

「あい（スペース）うえお（スペース）（スペース） かきく（スペース） けこ（改行）
さし（スペース）すせそ（改行）
た（スペース）な」
の場合は 、A1「あい」 B1「うえお」 C1「かきく」 D1「けこ」
A2「さし」B2「すせそ」
A3「た」B3「な」

といった具合です。

お礼日時：2016/08/17 09:50

No.3 回答者： GooUserラック 回答日時： 2016/08/17 04:06

こんなのはいかがですか？

----------------------------------------------------------------------
Sub Sample()

Dim ClipBoard As Variant
Dim RowNo As Long
Dim ColNo As Long
Dim StrNo As Long
Dim StrLen As Long
Dim StrVar As String
Dim StrCell As String

ClipBoard = Application.ClipboardFormats
If ClipBoard(1) = xlClipboardFormatText Then
ActiveSheet.Paste Destination:=Range("A1")
For RowNo = 1 To Cells(Rows.Count, 1).End(xlUp).Row
StrVar = Cells(RowNo, 1).Value
StrLen = Len(StrVar)
StrNo = 1
ColNo = 1
StrCell = ""
Do While StrNo <= StrLen
Select Case Mid(StrVar, StrNo, 1)
Case " "
If Mid(StrVar, StrNo + 1, 1) = " " Then
StrCell = StrCell & " "
StrNo = StrNo + 1
Else
Cells(RowNo, ColNo).Value = StrCell
StrCell = ""
ColNo = ColNo + 1
End If
Case Else
StrCell = StrCell & Mid(StrVar, StrNo, 1)
End Select
StrNo = StrNo + 1
Loop
If StrNo > StrLen Then Cells(RowNo, ColNo).Value = StrCell
Next
End If

End Sub
----------------------------------------------------------------------
区切り文字は、半角スペースのみですが、以下の「" "」（３箇所）を変更したものを追加していけば増やせます。
----------------------------------------------------------------------
Case " "
If Mid(StrVar, StrNo + 1, 1) = " " Then
StrCell = StrCell & " "
StrNo = StrNo + 1
Else
Cells(RowNo, ColNo).Value = StrCell
StrCell = ""
ColNo = ColNo + 1
End If
----------------------------------------------------------------------

この回答へのお礼

どうもありがとうございます！取りあえず動かしてみましたが、想定に近い動作をしてくれました。

唯一の問題はスペースが連続したときに区切りも連続して入ってしまう（？）点です。これはWindFaller様の回答を参考に修正できるのかなと拝察しましたので、修正に努めてみます。

お礼日時：2016/08/17 10:06

No.4 回答者： WindFaller 回答日時： 2016/08/17 09:08

#3さんの「Application.ClipboardFormats」は知らなかったです。

ヘルプで調べました。Excel2007以上にあるものなのですね。

#2で書いた
》これ以上のもの(様々なフォーマットを扱うクリップボード）を望まれると、
》掲示板の域を超えてしまうことになると思います。

という発言は撤回させていただきます。すみませんでした。
これは、Win32 APIを想定したものです。いままで、APIで使っていたものは、今後は、そちらに切り替えてみようと思います。
また、ひとつ勉強になりました。

なお、これは、
Const CLSID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"

RegSeeker とOLEVIEWで、調べられます。(両方共フリーな上に、かなり役に立つツールです。)

No.5 回答者： GooUserラック 回答日時： 2016/08/17 10:30

No.3「この回答へのお礼」について

あれ？スペースが2文字続いたときはスペース１文字にして区切らないのではないのでしょうか？詳しく説明いただけないでしょうか？

No.4 WindFallerさんへ
参照設定すれば Excel2003 等でも使えます。
リストに「Microsoft Forms 2.0 Object Library」が有ればチェックを入れます。
無ければ「C:\Windows\System32\FM20.DLL」または「C:\Windows\SysWOW64\FM20.DLL」を指定します。

この回答へのお礼

「あい（スペース）うえお（スペース）（スペース） かきく（スペース） けこ（改行）
さし（スペース）すせそ（改行）
た（スペース）（スペース）（スペース）な」
の場合は 、A1「あい」 B1「うえお」 C1「かきく」 D1「けこ」
A2「さし」B2「すせそ」
A3「た」B3「な」

といった動作を望んでいます。
pdfからコピーしたテキスト（表の形）をexcelに単純にペーストすると、A列に行すべてのテキストが貼り付けられたり、環境により列ごとに区切られることもあるのですが、意図しない空白セルが入ったりしています。
今は貼り付け後にテキスト ファイル ウィザードで、

区切り文字→スペース
連続した区切り文字は1文字として扱うにチェック

と設定しているのですが、この動作をマクロ化し、他のマクロと組み合わせたいと思っています。

お礼日時：2016/08/17 11:32

No.6 回答者： GooUserラック 回答日時： 2016/08/17 10:43

もしかしたらスペースは何文字続いても１つの区切り文字として扱うと言うことですか？それならば以下のようなものでいかがでしょうか？

----------------------------------------------------------------------
Sub Sample2()

Dim ClipBoard As Variant
Dim RowNo As Long
Dim ColNo As Long
Dim StrNo As Long
Dim StrLen As Long
Dim StrVar As String
Dim StrCell As String

ClipBoard = Application.ClipboardFormats
If ClipBoard(1) = xlClipboardFormatText Then
ActiveSheet.Paste Destination:=Range("A1")
For RowNo = 1 To Cells(Rows.Count, 1).End(xlUp).Row
StrVar = Cells(RowNo, 1).Value
StrLen = Len(StrVar)
StrNo = 1
ColNo = 1
StrCell = ""
Do While StrNo <= StrLen
Select Case Mid(StrVar, StrNo, 1)
Case " "
If Mid(StrVar, StrNo + 1, 1) <> " " Then
Cells(RowNo, ColNo).Value = StrCell
StrCell = ""
End If
StrNo = StrNo + 1
Case Else
StrCell = StrCell & Mid(StrVar, StrNo, 1)
End Select
StrNo = StrNo + 1
Loop
If StrNo > StrLen Then Cells(RowNo, ColNo).Value = StrCell
Next
End If

End Sub
----------------------------------------------------------------------
これだとスペース文字を残すことが出来ませんが良いのでしょうか？

No.7 回答者： GooUserラック 回答日時： 2016/08/17 10:54

No.6 訂正です。

違う行を削除してしまいました。
----------------------------------------------------------------------
Sub Sample2()

Dim ClipBoard As Variant
Dim RowNo As Long
Dim ColNo As Long
Dim StrNo As Long
Dim StrLen As Long
Dim StrVar As String
Dim StrCell As String

ClipBoard = Application.ClipboardFormats
If ClipBoard(1) = xlClipboardFormatText Then
ActiveSheet.Paste Destination:=Range("A1")
For RowNo = 1 To Cells(Rows.Count, 1).End(xlUp).Row
StrVar = Cells(RowNo, 1).Value
StrLen = Len(StrVar)
StrNo = 1
ColNo = 1
StrCell = ""
Do While StrNo <= StrLen
Select Case Mid(StrVar, StrNo, 1)
Case " "
If Mid(StrVar, StrNo + 1, 1) <> " " Then
Cells(RowNo, ColNo).Value = StrCell
StrCell = ""
ColNo = ColNo + 1
End If
Case Else
StrCell = StrCell & Mid(StrVar, StrNo, 1)
End Select
StrNo = StrNo + 1
Loop
If StrNo > StrLen Then Cells(RowNo, ColNo).Value = StrCell
Next
End If

End Sub
----------------------------------------------------------------------

この回答へのお礼

コードの内容は理解できていないのですが…
動作だけみると、普通にペーストしたときとマクロでペーストしたときで結果に違いがありません…。

お礼日時：2016/08/17 11:34

No.8 ベストアンサー 回答者： ki-aaa 回答日時： 2016/08/17 11:07

こんなので、どうかな

'
'メモ帳の複数行をコピーする。
'
Sub クリップボードにあるテキストデータをスペースを区切り文字()
Dim objClip As Object
Dim pData As String


'クリップボードのセット
Set objClip = GetObject("New:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
With objClip
.GetFromClipboard
pData = WorksheetFunction.Trim(.GetText)
pData = Replace(pData, " ", Chr(9))
Application.CutCopyMode = False
End With


Set objClip = GetObject("New:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
With objClip
.SetText pData
.PutInClipboard
End With


Cells(1, "A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

この回答へのお礼

素晴らしいです！
（細かいところまではチェックしきれていませんが）完璧に望み通りの結果が得られています。

どうもありがとうございました。

お礼日時：2016/08/17 11:51

No.9 回答者： WindFaller 回答日時： 2016/08/17 13:57

こんにちは。

#2の回答者です。

改良型と言いたいのですが、あまり複雑になると、やはりダイアログにしたほうが良いようです。ここのテキストファイルウィザードと同じようなものは私も作れるのですが、マクロの意味がなくなってしまいます。また、テキストファイルウィザードそのものを利用しても作れるのですが、一定以上のスキルがあるという自負があると、なかなかお仕着せのものは使いづらいです。記録マクロを応用すれば、簡単に出来上がります。(出てきたコードに、最後にQueryTables(1).Delete だったかな、それを加えれば、完璧のはずです）

テキストファイルウィザードの設定は、複数を使うことが可能ですが、その場合は、私は、BRegExp.dll/Basp21 というツール(公に認められています）を使います。

現状では、スペース区切りと他の区切り文字とは、多数は共存はできませんが、区切り文字を「、(読点）」「, (カンマ）」などの文字列とした場合も区切れるようにしました。安易ですが、スペースに変えるわけです。

また、Windowsの場合は、Chr(13) =CR を使って区切ってしまうと、Chr(10)=LFが、次の行の文字列に残ってしまうようですので、予め、削除することにしました。

Excelでは、数式などは、'=AB1' だと文字に入りませんので、それも加えました。ただ、経験値を活かしても、せいぜい、こんなものです。単純明快なコードのほうが最近は好まれるようですが……。

'//
Sub OutputfmrClipboardR()
　Dim CB As Object
　Dim buf As Variant, ea As Variant
　Dim arBufs As Variant
　Dim arBuf As Variant
　Dim stc As Variant
　Dim i As Long, j As Long, k As Long
　Const CLSID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
　
　Set CB = CreateObject("new:" & CLSID)
　
　'Const DELIM As String = "、" '文字を区切り文字を使う場合(下も外す）
　
　On Error GoTo ErrHandler
　Range("A1").Select 'A1 を最初とする
　With CB
　　.GetFromClipboard
　　buf = .GetText
　　If VarType(buf) = vbString Then
　　　'buf = Replace(buf, DELIM, Space(1), , , vbTextCompare) ''区切り文字を使う場合
　　　arBufs = Split(buf, Chr(13), , vbBinaryCompare)
　　　For Each stc In arBufs
　　　　If Len(stc) > 0 Then
　　　　　'全角空白を半角に
　　　　　buf = Replace(stc, Space(1), Space(1), , , vbTextCompare)
　　　　　'空白は2個以上は、1つにまとめる
　　　　　Do
　　　　　　buf = Replace(buf, Space(2), Space(1), , , vbTextCompare)
　　　　　Loop Until InStr(buf, Space(2)) = 0
　　　　　
　　　　　'Windows用　不要な改行コードを落とす
　　　　　buf = Replace(buf, Chr(10), "", , , vbBinaryCompare)
　　　　　arBuf = Split(buf, Space(1))
　　　　　j = UBound(arBuf)
　　　　　If j > -1 Then
　　　　　　For i = 0 To j
　　　　　　　'Excelでは、セルの文頭に使えない文字がある
　　　　　　　If arBuf(i) Like "[-+=]*" Then
　　　　　　　　ea = "'" & arBuf(i)
　　　　　　　Else
　　　　　　　　ea = arBuf(i)
　　　　　　　End If
　　　　　　　'不要なバイナリコードをセルには入れない。
　　　　　　　 ActiveCell.Offset(k, i).Value = Application.Clean(Trim(ea))
　　　　　　Next i
　　　　　End If
　　　　　k = k + 1
　　　　End If
　　　Next stc
　　End If
　End With
ErrHandler:
　Set CB = Nothing
　If Err() <> 0 Then
　　MsgBox Err.Number & " :" & Err.Description
　End If
End Sub

'//

GooUserラック様へ。
ありがとうこざいました。これで終止符を打てると思ってClipboardFormats を使おうと思いましたが、取り出すほうは、また関数が用意されていないようです。ここで、取り出すAPI関数を使おうとも考えてみましたが、ちょっと大げさ過ぎてしまいますので、やめにしました。

私は、長い間、この件は、いろんな方法を試してみて、し尽くしているつもりですから、当然、「Microsoft Forms 2.0 Object Library」の参照設定は知っているのですが、なかなか容易には使わせてもらえないような気がします。

この回答へのお礼

こちらも完璧に動きました！ありがとうございました。

お礼日時：2016/08/17 14:58