人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルVBAで、「 クリップボード上にある文章から、エクセルシートにそれぞれ貼り付けしたい。


「文章」というシートのA1内に長い文章があります(可能な文字数)

その中が、以下のような感じだとします。


「1名前」和歌山県産「終わり」
「1品物」みかん「終わり」
「1説明」とても甘いです「終わり」

「2名前」青森県産「終わり」
「2品物」りんご「終わり」
「2説明」無農薬です「終わり」



「15名前」「終わり」
「15品物」バナナ「終わり」
「15説明」量が多いです「終わり」


数字は一応50くらいまで。難しいのであれば、20までとします。数字は全角の場合もあります。「」はわかりやすくするためで本来はありません。終わりという言葉で区切りをつけていますが、必要なければ、なくても判定していただける方がベターです。(「終わり」を一切無視してOKです)



【VBAマクロ】
そこでマクロをはじめると、
「ons」というシート名の各場所に振り分けてコピー&ペースト(上書き)できるようにしてほしいのです。


【貼り付け先の該当場所は画像をご参考にお願いします】


どうかよろしくお願いいたします。

1331193307
●拡大する

●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● oil999
●300ポイント ベストアンサー

コメントいただいた要件を実行できるようにマクロを修正しました。

VBAでクリップボードを扱うための前準備

  1. 開発 → マクロ → VisualBasic
  2. VisualBasicEditerで ツール → 参照設定
  3. 参照設定で Microsoft Forms 2.0 Object Library にチェックを入れてください。

Microsoft Forms 2.0 Object Libraryが見つからない場合は、以下のサイトを参考にしてください。
http://pc.k-solution.info/programming/vba/excelvba1.aspx

マクロ本体

クリップボードの内容に「」や「終わり」は含まれておらず、以下のようになっているとします。
数字の制限は設けていません。(メモリが許す限りOKのはず)
ただし、数字の次に、名前, 品物, 説明 のいずれかの文字があることが前提です。また、シート "ons" が存在していることが前提です。(シートの内容をクリアせず、そのまま代入するようにしてあります)

1名前
和歌山県産

1品物
みかん

1説明
とても
甘いです

2名前青森県産
2品物りんご
2説明無農薬です

ただし、次のようなクリップボードは正常に処理できません。
数字+名前, 品物, 説明のいずれかの文字が同じ行になっていることが前提です。

1名前和歌山
県産

1品物
みかん

1説明とても
甘いです



マクロは次のようになります。

Option Explicit

'クリップボードの内容を取り出す
Function getClipBoard() As String
 Dim CB As Object
 Set CB = New DataObject
 With CB
 .GetFromClipboard
 getClipBoard = .GetText
 End With
End Function

Sub main()
 Dim str As String, items() As String
 Dim i As Long, j As Long, r As Long
 Dim re As Object
 Dim remat As Variant
 Dim key As String, val As String, name As String
 
 name = "ons"  'シート名
 str = getClipBoard()
 items = Split(str, vbCrLf)
 Set re = CreateObject("VBScript.RegExp")
 For i = LBound(items) To UBound(items)
 With re
 .Pattern = "([0-9]+)(名前|品物|説明)(.*)"
 .IgnoreCase = True
 .Global = True
 Set remat = .Execute(items(i))
 If remat.Count > 0 Then
 r = remat(0).SubMatches(0) + 1  '行番号
 key = remat(0).SubMatches(1)  '見出し
 val = remat(0).SubMatches(2)  'データ
 If (val = "") Then
 i = i + 1
 While (i <= UBound(items) And items(i) <> "")
 val = val & items(i) & vbCrLf
 i = i + 1
 Wend
 val = Left(val, Len(val) - 1)
 End If
 Select Case key
 Case "名前"
 Worksheets(name).Cells(r, 2) = val
 Case "品物"
 Worksheets(name).Cells(r, 3) = val
 Case "説明"
 Worksheets(name).Cells(r, 9) = val
 End Select
 End If
 End With
 Next i
 Set re = Nothing
End Sub



naranara19さんのコメント
ありがとうございます! 早速やってみました。うまく動きました。 感謝します。 もう少しだけお付き合いいただいてもよろしいでしょうか? 1名前 和歌山県産 1品物 みかん 1説明 とても 甘いです 2名前青森県産 2品物りんご 2説明無農薬です ↑このように、改行がはいったもののクリップボード上だと、 改行後のペーストはされなくなっております。改行されていても、 コピーするようにできないでしょうか?お手数をおかけしますが、 ご返信お待ちしております。

oil999さんのコメント
マクロを修正しました。お試しください。

naranara19さんのコメント
ありがとうございました!とても助かりました。今後もぜひ何か質問したときには、お答えいただけたらうれしいです!

2 ● TransFreeBSD
●100ポイント

まあoil999さんとほぼ一緒ですけど、こうですよね?
あと、ちょっと改良点も。

Option Explicit

Sub Macro1()
 Dim dst, re, match, culmun As String
  ' 以下2行をコメントアウトすると、現在選択中のセルを対象にする。
 Worksheets("文章").Activate
 Range("A1").Select
  ' 記入シートは以下で設定
 Set dst = Worksheets("ons")
 Set re = CreateObject("VBScript.RegExp")
  ' 改行で説明終わりなら、「終わり」は必要なく以下でOK
 re.Pattern = "([0-90-9]+)(名前|品物|説明)(.*)"
  ' 以下だと改行なしも説明とか「終わり」までに改行もOK
  're.Pattern = "([0-90-9]+)(名前|品物|説明)([\s\S]*?)終わり"
 re.Global = True
 For Each match In re.Execute(Selection.Value)
 Select Case match.SubMatches(1)
 Case "名前"
 culmun = "B"
 Case "品物"
 culmun = "C"
 Case "説明"
 culmun = "I"
 End Select
 dst.Range(culmun & match.SubMatches(0) + 1).Value = match.SubMatches(2)
 Next
End Sub

以下の代わりに

 re.Pattern = "([0-90-9]+)(名前|品物|説明)(.*)"

以下を使うと

 re.Pattern = "([0-90-9]+)(名前|品物|説明)([\s\S]*?)終わり"

以下のように、「終わり」が必要になりますが、途中で改行もokだし、改行なしでもokになります。

1名前和歌山県産終わり
1品物みかん終わり
1説明とても
甘いです終わり
2名前青森県産終わり2品物りんご終わり 12説明無農薬です終わり


naranara19さんのコメント
ありがとうございました!さっそくやったのですが、実行時のエラー9がでてしまいます。oil999さんのご回答はでないので、コードに何か問題があるのかもしれないです。途中改行に気づいてくれたことがとてもうれしいです。改行の件を打ち込んだあとにTransFreeBSDさんのご回答に気づきました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ