▽1
●
oil999 ●300ポイント ベストアンサー |
コメントいただいた要件を実行できるようにマクロを修正しました。
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
まあ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説明無農薬です終わり