コピペマクロ制作にご協力ください。

エクセルファイルにあらかじめMicrosoft Forms 2.0 Object Libraryを参照設定しておいてください。クリップボードを参照するために必要です。（そんなに難しくないです）
https://www.relief.jp/docs/017881.html

上記設定が出来たらお試しください。

Sub Sample()
Dim buf2 As String, CB As New DataObject
    With CB
        .GetFromClipboard   ''クリップボードからDataObjectにデータを取得する
        buf2 = .GetText     ''DataObjectのデータを変数buf2に取得する
    End With
  
    buf2 = "★" & buf2  ''文頭に★を追加
    buf2 = Replace(buf2, vbCrLf, "★") ''改行を★に置換
    buf2 = Replace(buf2, "　", "") ''全角スペースを削除
    buf2 = Replace(buf2, " ", "") ''半角スペースを削除
    buf2 = Replace(buf2, "なにかいらない文字列", "") ''「なにかいらない文字列」があれば削除（適当に変えてください）

Dim strTemp2 As String              ''↓連続した★の削除
buf2 = Replace(buf2, "★★", "★")
strTemp2 = InStr(buf2, "★★")
Do Until strTemp2 = 0
    buf2 = Replace(buf2, "★★", "★")
    strTemp2 = InStr(buf2, "★★")
Loop                                 ''↑連続した★の削除

                             
Dim arr() As Variant, elm As Variant ''↓★項目名を配列arrに入れて★に置換
arr = Array("★名前", "★しなもの", "★種類", "★保管", "★配送料", "★詳細", "★おおきさ", "★カテゴリ", "★値段", "★ＪＡＮ", "★即決")
    
For Each elm In arr
        buf2 = Replace(buf2, elm, "★")
    Next elm                        ''↑★項目名を配列arrに入れて★に置換
    
buf2 = Mid(buf2, 2) ''文頭の★を削除

Dim arr2() As String

arr2 = Split(buf2, "★") ''★で区切って一次元配列arr2にいれる


Dim err As Long

err = UBound(arr2) - LBound(arr2) + 1 ''配列arr2の総数を変数errに格納

If err Mod 11 = 0 Then ''配列arr2の総数が項目数11で割り切れるかエラー判定

    For i = LBound(arr2) To UBound(arr2)
        c = i Mod 11 + 1                    ''割り算の余り、横に１づつ増え１１になったら折り返す
        r = i \ 11 + 1                      ''割り算の商、１１で割れる整数が出たら縦に増える
        Cells(r + 1, c) = arr2(i)           ''記入セルをＡ２から始めるのでr+1（Ａ３にする場合はr+2）
    Next

Else
    MsgBox ("エラー、読み取りデータの改行位置を確認してください")   ''エラーメッセージ
  
End If
End Sub

元データをコピーした状態（クリップボードにデータがある状態）で実行すると動くはず…！エラーメッセージが出たら教えてください。

Sub Sample()
Dim buf2 As String, CB As New DataObject
    With CB
        .GetFromClipboard   ''①クリップボードからDataObjectにデータを取得する
        buf2 = .GetText     ''DataObjectのデータを変数buf2に取得する
    End With


If InStr(buf2, "∇") > 0 Or InStr(buf2, "Ж") > 0 Then     ''↓②エラー処理。元データに指定記号あったら中断
MsgBox "元データの∇かЖを削除してやり直してください"
Exit Sub
End If                                                 ''↑②エラー処理。元データに指定記号あったら中断


''↓③正規表現で項目名を検索、置換（ラベルをつける）

Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = False '大文字と小文字を区別するか(False)、しないか(True)
    reg.Global = True      '文字列全体を検索するか(True)、しないか(False)

    
    buf2 = vbCrLf & buf2                              '文頭に改行を追加
    
    reg.Pattern = "\n\d{1,}\(\d{1,}\)"                '「改行　数字列(数字数字列)」を検索
    buf2 = reg.Replace(buf2, "")                      '削除
    reg.Pattern = "\n\d{1,}名前"                     '「改行 数字列1桁以上 名前」を検索
    buf2 = reg.Replace(buf2, "Ж∇namae∇")            '置換
    reg.Pattern = "\n\d{1,}品物"
    buf2 = reg.Replace(buf2, "Ж∇shina∇")
    reg.Pattern = "\n\d{1,}JANコード･ISBNコード"
    buf2 = reg.Replace(buf2, "Ж∇janco∇")
    reg.Pattern = "\n\d{1,}自社カテゴリ"
    buf2 = reg.Replace(buf2, "Ж∇zisya∇")
    reg.Pattern = "\n\d{1,}保管場所"
    buf2 = reg.Replace(buf2, "Ж∇hokan∇")
    reg.Pattern = "\n\d{1,}送料"
    buf2 = reg.Replace(buf2, "Ж∇soury∇")
    reg.Pattern = "\n\d{1,}説明"
    buf2 = reg.Replace(buf2, "Ж∇setum∇")
    reg.Pattern = "\n\d{1,}サイズ"
    buf2 = reg.Replace(buf2, "Ж∇saizu∇")
    reg.Pattern = "\n\d{1,}カテゴリ"
    buf2 = reg.Replace(buf2, "Ж∇kateg∇")
    reg.Pattern = "\n\d{1,}開始価格"
    buf2 = reg.Replace(buf2, "Ж∇kaisi∇")
    reg.Pattern = "\n\d{1,}即決価格"
    buf2 = reg.Replace(buf2, "Ж∇sokke∇")
        
    
    reg.Pattern = "\n\d{1,}しなもの"                 '元データの項目名に表記ゆれがある場合のコード(不要なら削除)
    buf2 = reg.Replace(buf2, "Ж∇shina∇")          '元データの項目名に表記ゆれがある場合のコード(不要なら削除)
    
    
''↑③正規表現で項目名を検索、置換（ラベルをつける）
    
''↓④改行・スペースなど不要なものを削除
    
    buf2 = Replace(buf2, vbCrLf, "")                '改行を削除
    buf2 = Replace(buf2, vbCr, "")                  '改行を削除
    buf2 = Replace(buf2, vbLf, "")                  '改行を削除
     
    
    buf2 = Replace(buf2, "　", "") '全角スペースを削除
    buf2 = Replace(buf2, " ", "") '半角スペースを削除
    
    buf2 = Replace(buf2, "なにかいらない文字列", "") '「なにかいらない文字列」があれば削除（不要なら削除）

buf2 = Mid(buf2, 2) '文頭のЖを削除

Dim arr2() As String
arr2 = Split(buf2, "Ж") ''⑤Жでbuf2を区切って一次元配列arr2にいれる


''⑥↓配列に入れたデータを振り分ける

Dim r As Long, err As Long, errtxt As String

errtxt = ActiveWorkbook.Path & "\errtxtabc.txt" 'エラーテキストのアドレスとファイル名
 
err = UBound(arr2) - LBound(arr2) + 1 '配列arr2の総数(セルに入れるデータの数)を変数errに格納

If err Mod 11 = 0 Then                   ''⑥－①変数errが11で割り切れるかエラー判定
                                                       
    For i = LBound(arr2) To UBound(arr2)                ''（上記エラー条件に当てはまらない場合）⑥－②↓セルに振り分け

    
    r = i \ 11 + 1                      ''割り算の商、iが11の倍数に達すると１ずつ増える値ｒ（iの初期値が0なので+1）
       
        If InStr(arr2(i), "∇namae∇") = 1 Then                   '配列の最初が∇namae∇なら
        Cells(r, 1).Offset(1, 0) = arr2(i)                        'A列に（B列の2行目開始ならCells(r, 2).Offset(1, 0)）
        ElseIf InStr(arr2(i), "∇shina∇") = 1 Then
        Cells(r, 3).Offset(1, 0) = arr2(i)                        'C列（C列の4行目開始ならCells(r, 3).Offset(3, 0)）
        ElseIf InStr(arr2(i), "∇janco∇") = 1 Then
        Cells(r, 37).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇zisya∇") = 1 Then
        Cells(r, 4).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇hokan∇") = 1 Then
        Cells(r, 5).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇soury∇") = 1 Then
        Cells(r, 8).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇setum∇") = 1 Then
        Cells(r, 9).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇saizu∇") = 1 Then
        Cells(r, 10).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇kateg∇") = 1 Then
        Cells(r, 14).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇kaisi∇") = 1 Then
        Cells(r, 20).Offset(1, 0) = arr2(i)
        ElseIf InStr(arr2(i), "∇sokke∇") = 1 Then
        Cells(r, 65).Offset(1, 0) = arr2(i)
        
        Else
        MsgBox "振り分けエラー"
        Exit Sub
        End If
        
    Next i

Else
    Open errtxt For Output As #1
    Print #1, buf2                            ''⑥－①のエラー判定に当てはまる場合、buf2をテキスト書き出し"
    Close #1
    MsgBox "エラー。読み取りデータが１１の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。"
End If

''⑥↑配列に入れたデータを振り分ける


Cells.Replace what:="∇?????∇", Replacement:=""  ''⑦ラベルを削除



End Sub

修正点
・★と▲
・記号エラー判定が不確実だったので修正
・画像に合わせて、ＪＡＮコード・ＩＳＢＮコード→JANコード･ISBNコードに
・⑥-②項目を各セルに振り分けるときの縦方向のずらしをOffset関数で指定（こっちの方が後で変更しやすい）
・エラーがあったら内容をerrtxtabc.txtに書き出し
・コード内説明文を追加

どういう処理をしてるのか噛み砕いて説明します。

①クリップボードからデータを読み込む
改行を含めた長～い文字列として変数buf2に入れる

②エラー判定・処理
元データに指定記号（今は∇とЖ）があったらマクロ中断。

③項目名を検索して置換
通常の置換ではなく正規表現で置換してます。
\n→改行　\d{1,0}→1桁以上の数字列 \(→(　\)→) の意味。
ここで「1名前」や「33名前」という項目名を検索して「Ж∇namae∇」という文字に置き換え。「1品物」「1JANコード･ISBNコード」という文字もそれぞれ対応するラベル「Ж∇～～～∇」に置換。

④改行・スペースの削除　文頭のЖを削除（Spilit関数を使うため）

⑤Spilit関数で長～い文字列データbuf2を、Жで区切る。buf2が配列arr2になる。
∇namae∇～～～｜壁｜∇shina∇～～～|壁|∇janco∇～～～｜壁｜
壁で仕切られた部屋に各項目が入るイメージ。Жはデータから消える。

⑥-①エラー判定
壁で仕切られた部屋の総数（=配列arr2の総数）を数え、11の倍数であれば処理続行。エラーならエラー処理（後述）へ。

⑥-②各部屋の先頭文字列∇～～～∇を調べる
指定した１１条件のうちどれかに該当すれば一部屋分のデータを指定したセルに記入。arr2配列の総数分、処理を繰り返す。

⑥-①エラー処理
エラー判定に該当した場合、新規テキストファイルにbuf2の内容を書き出し

⑦∇～～～∇を全て消す
?　→　１文字。ラベル名は全て５文字なので「∇?????∇」

おわり

特に重要なのが③です。こちらでは元データが分からないため、検索してる項目名が元データに対応しているのかそちらで確認して修正してください。改行位置や全角半角がコードの指示と違えばエラーになります。現行コードでは全角の数字列３３３（５１７）は削除されないし、全角のＪＡＮコード・も置換されない。現在は半角のJANコード･に対応。

★エラーになる場合★
処理途中のデータをテキストファイルで確認できるようにしました。
errtxtabcという名前でマクロ実行ファイルと同じディレクトリに作られます。エラー原因が分からない場合、テキストファイルの内容を教えてください。

コメントの半角の￥マークが自動的に\へ変換されてしまいました・・・。③の正規表現についての説明は下記のようになります。コードは問題ありません。
\n　　　\d{1,0}　 　　　\(　　　　 　\)
↓　　　　↓　　　　　　↓　　　　　↓
半角￥n　半角￥d{1,0}　半角￥(　　半角￥)

子育て中の趣味でやってるのでお気遣いなく～。

エラーテキストの内容は、⑤の直前、全ての置換と不要数字列の削除が終わった後、文字列データbuf2の中身です。出てきたエラーテキストを、Жの手前で改行すると下記のようになります。（文頭のみЖがない理由はコード内で説明）
∇namae∇パナソニック
Ж∇shina∇冷蔵庫。新品。2018年製1JANコード・ISBNコード
Ж∇zisya∇
Ж∇hokan∇E8☆
Ж∇soury∇宅2000
Ж∇setum∇新品未使用のお品となります。
Ж∇saizu∇
Ж∇kateg∇
Ж∇kaisi∇200000
Ж∇sokke∇

足りない項目がありますよね！！そうですJANコード・ISBNコードが正しく置換できてません！！

投稿がうまくいきませんでした。

reg.Pattern = "\n\d{1,}JANコード･ISBNコード" buf2 = reg.Replace(buf2, "Ж∇janco∇")

の部分 JANコード･ISBNコード　のところを JANコード・ISBNコード に変えてください。
あとわざわざ追記した正規表現の説明について誤記がありました。混乱させてすいません。（コードは合っています）
https://msdn.microsoft.com/ja-jp/library/cc392020.aspx
私の説明より上記サイトをみながらコードの③の部分を色々いじってみて、でてきたerrtxrabc.txtを見てみれば、①～④でどういう処理をしてるか分かるかと思います。
「1開始価格200000<改行>1即決価格」は大丈夫です。改行がなく「1開始価格2000001即決価格」であればエラーになります。

マイクロソフトのサイトをすすめましたが、
https://excel-ubara.com/excelvba4/EXCEL232.htmlの方がいいかも…。
マイクロソフトの方は￥の記号が＼に置き換わってる可能性あるので…。度々すいません。

先頭の項目名が削除されませんか。何ででしょうね。

Cells.Replace what:="∇?????∇", Replacement:=""  ''⑦ラベルを削除

↑このコードを削除して代わりに下記のコードを入れてみてください。

     ''⑦ラベルを削除
With Cells
.Replace What:="∇namae∇", Replacement:=""
.Replace What:="∇shina∇", Replacement:=""
.Replace What:="∇janco∇", Replacement:=""
.Replace What:="∇zisya∇", Replacement:=""
.Replace What:="∇hokan∇", Replacement:=""
.Replace What:="∇soury∇", Replacement:=""
.Replace What:="∇setum∇", Replacement:=""
.Replace What:="∇saizu∇", Replacement:=""
.Replace What:="∇kateg∇", Replacement:=""
.Replace What:="∇kaisi∇", Replacement:=""
.Replace What:="∇sokke∇", Replacement:=""
End With

記号について
見た目が近いですが▽と∇は違う記号です。∇は、「記号」で変換すると出てくるナブラという数学記号です。「三角」と打っても出てきません。とはいえこちらで全く使わない記号というのは判断しかねます。プログラムが問題なく動くようになったら最後にご自分で変えてください。

●変え方
VBE（マクロを編集するときに出てくるアプリケーション）の上部にある　編集→置換の画面で∇をЮでも何でも任意の記号に変えてください。（「すべて置換」より「置換」の方がひとつずつ目視で確認できるのでお勧め）
記号エラー処理も含めてコード内すべての∇が任意の記号に置き換わります。簡単な作業かと私は思いますが、どうしても難しいようなら置換したコードを追記します。その場合は希望する記号を指定してください。

うまくいかない原因が不明です…。コードの「'配列の最初が∇namae∇なら」の行の部分
　Cells(r, 1).Offset(1, 0) = arr2(i)　を
→Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8)にすれば、Replaceを使わなくてもいけます。
具体的に言うと。

       If InStr(arr2(i), "∇namae∇") = 1 Then                   '配列の最初が∇namae∇なら
        Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8)                       'A列へ８文字目以降を転記（B列の2行目開始ならCells(r, 2).Offset(1, 0)）
        ElseIf InStr(arr2(i), "∇shina∇") = 1 Then
        Cells(r, 3).Offset(1, 0) = Mid(arr2(i), 8)                       'C列へ８文字目以降を転記（C列の4行目開始ならCells(r, 3).Offset(3, 0)）
        ElseIf InStr(arr2(i), "∇janco∇") = 1 Then
        Cells(r, 37).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇zisya∇") = 1 Then
        Cells(r, 4).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇hokan∇") = 1 Then
        Cells(r, 5).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇soury∇") = 1 Then
        Cells(r, 8).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇setum∇") = 1 Then
        Cells(r, 9).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇saizu∇") = 1 Then
        Cells(r, 10).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇kateg∇") = 1 Then
        Cells(r, 14).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇kaisi∇") = 1 Then
        Cells(r, 20).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇sokke∇") = 1 Then
        Cells(r, 65).Offset(1, 0) = Mid(arr2(i), 8)
        
        Else
        MsgBox "振り分けエラー"
        Exit Sub
        End If
        
    Next i

Else
    Open errtxt For Output As #1
    Print #1, buf2                            ''⑥－①のエラー判定に当てはまる場合、buf2をテキスト書き出し"
    Close #1
    MsgBox "エラー。読み取りデータが１１の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。"
End If

End Sub

r = i ￥ 11 + 1の下の部分、後半をごっそり上記コードに入れ替えてください。
⑦を削除し、振り分けのコードを変えてます。

こちらでは元データが確認できないため、エラー処理をわざわざ３つ設定してあります。こちらで決めた規則に元データが合致しなければ処理しないようにしてます。（本当は間違ってるのにもっともらしいデータができても困りますよね）そのため「うまくいかない」と感じられるのかもしれません。原因が分かれば修正は簡単だと思いますよ～。
ちなみに⑦のReplaceがうまくいかなかった原因が、私には分かりませんでした。
セルの各先頭が全て∇namae∇などになったままっていうことですよね？

後学のために質問なんですが、
A1セルに、　あいうえおかきくけこ　書いた状態で下記マクロを作動しても全然変わりません？もしよければ教えてください。

Sub aiueo()
Cells.Replace what:="あいうえお", Replacement:=""
End Sub

参照設定を行っていない為だと思われます。

以下のリンク先の「事前の準備」を参考にして
Microsoft VBScript Regular Expressions 5.5
にチェックをいれてから、再度実行してみてください。

VBAで正規表現を使う (1/3)：CodeZine（コードジン）