ｺﾒﾝﾄいただいた要件を実行できるようにﾏｸﾛを修正しました｡

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

まあ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説明無農薬です終わり