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

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

メールなどクリップボード上にある、テキストデータをエクセルの所定の
場所にはりつけたいのです。詳しくは画像をご確認ください。

番号別に、A2行目から順番にはりつけたいと思っています。
しかし、文章が長くなったり、内側に改行コードがあると、エラーが出やすいようです。

それらを回避して貼り付けを実行願います。何も入っていないところは特に実行しなくて大丈夫です。

今後変えられるように、貼付の列番号の「A」や「AM」などは変えられるようにしておいていただけると
幸いです。

よろしくお願いいたします。

1549662275
●拡大する

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

▽最新の回答へ

1 ● フームー母
●100ポイント

画像を確認しましたが、文字がつぶれてみえませんでした。(こちらの環境のせいかもしれませんが)
画像を二つに分けて再投稿していただければ嬉しいです。


フームー母さんのコメント
エクセルファイルにあらかじめMicrosoft Forms 2.0 Object Libraryを参照設定しておいてください。クリップボードを参照するために必要です。(そんなに難しくないです) https://www.relief.jp/docs/017881.html 上記設定が出来たらお試しください。 >|vba| 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("★名前", "★しなもの", "★種類", "★保管", "★配送料", "★詳細", "★おおきさ", "★カテゴリ", "★値段", "★JAN", "★即決") 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 ''割り算の余り、横に1づつ増え11になったら折り返す r = i \ 11 + 1 ''割り算の商、11で割れる整数が出たら縦に増える Cells(r + 1, c) = arr2(i) ''記入セルをA2から始めるのでr+1(A3にする場合はr+2) Next Else MsgBox ("エラー、読み取りデータの改行位置を確認してください") ''エラーメッセージ End If End Sub ||<

naranara19さんのコメント
ありがとうございます。ぜひよろしくお願いいたします。

フームー母さんのコメント
元データをコピーした状態(クリップボードにデータがある状態)で実行すると動くはず…!エラーメッセージが出たら教えてください。

naranara19さんのコメント
ありがとうございます。少なくしてやってみますと、元データが11の倍数ではありません。と出ました。 多くしてやってみると、元データの▲か★を削除してやり直してくださいとでることが多かったです。▲や★などの記号系はよく使うことも多く、エラーとなりやすいかもしれません。数学のような文字は?(ポンド)以外使わないので、そちらなどを利用していただけるとありがたいかもしれません。

フームー母さんのコメント
>|vb| 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の倍数に達すると1ずつ増える値r(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 "エラー。読み取りデータが11の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。" End If ''?↑配列に入れたデータを振り分ける Cells.Replace what:="∇?????∇", Replacement:="" ''?ラベルを削除 End Sub ||< 修正点 ・★と▲ ・記号エラー判定が不確実だったので修正 ・画像に合わせて、JANコード・ISBNコード→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の倍数であれば処理続行。エラーならエラー処理(後述)へ。 ?-?各部屋の先頭文字列∇???∇を調べる 指定した11条件のうちどれかに該当すれば一部屋分のデータを指定したセルに記入。arr2配列の総数分、処理を繰り返す。 ?-?エラー処理 エラー判定に該当した場合、新規テキストファイルにbuf2の内容を書き出し ?∇???∇を全て消す ? → 1文字。ラベル名は全て5文字なので「∇?????∇」 おわり 特に重要なのが?です。こちらでは元データが分からないため、検索してる項目名が元データに対応しているのかそちらで確認して修正してください。改行位置や全角半角がコードの指示と違えばエラーになります。現行コードでは全角の数字列333(517)は削除されないし、全角のJANコード・も置換されない。現在は半角のJANコード・に対応。 ★エラーになる場合★ 処理途中のデータをテキストファイルで確認できるようにしました。 errtxtabcという名前でマクロ実行ファイルと同じディレクトリに作られます。エラー原因が分からない場合、テキストファイルの内容を教えてください。

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

naranara19さんのコメント
ありがとうございます。 エラー。読み取りデータが11の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。と出てしまいまして。 一例のエラーテキストはこんな感じになりました。 ∇namae∇パナソニックЖ∇shina∇冷蔵庫。新品。2018年製1JANコード・ISBNコードЖ∇zisya∇Ж∇hokan∇E8☆Ж∇soury∇宅2000Ж∇setum∇新品未使用のお品となります。Ж∇saizu∇Ж∇kateg∇Ж∇kaisi∇200000Ж∇sokke∇Ж∇namae∇タニタЖ∇shina∇体脂肪計。最新型2019年製2JANコード・ISBNコードЖ∇zisya∇Ж∇hokan∇Ж∇soury∇定700Ж∇setum∇新品未使用でございます。人気のタニタブランドのお品です。Ж∇saizu∇Ж∇kateg∇Ж∇kaisi∇3000Ж∇sokke∇ お手数をおかけいたします。 なお、 もしかしたらなのですが、 502(517) 1名前パナソニック 1品物冷蔵庫。新品。2018年製 1JANコード・ISBNコード 1自社カテゴリ 1保管場所E8☆ 1送料宅2000 1説明新品未使用のお品となります。 1サイズ 1カテゴリ 1開始価格200000 1即決価格 503(518) 2名前タニタ 2品物体脂肪計。最新型2019年製 2JANコード・ISBNコード 2自社カテゴリ 2保管場所 2送料定700 2説明新品未使用でございます。人気のタニタブランドのお品です。 2サイズ 2カテゴリ 2開始価格3000 2即決価格 みたいなテキストは1開始価格200000とつながっておりまして、カンマなどははいっていません。このせいかと思ったのですが、違いますでしょうか。200000のあとに改行はされております。 多大なお手数をおかけしております。きちんとした回答をしてくださっている方には必ずポイントは進呈しますのでご安心くださいませ。

フームー母さんのコメント
子育て中の趣味でやってるのでお気遣いなく?。 エラーテキストの内容は、?の直前、全ての置換と不要数字列の削除が終わった後、文字列データbuf2の中身です。出てきたエラーテキストを、Жの手前で改行すると下記のようになります。(文頭のみЖがない理由はコード内で説明) ∇namae∇パナソニック Ж∇shina∇冷蔵庫。新品。2018年製1JANコード・ISBNコード Ж∇zisya∇ Ж∇hokan∇E8☆ Ж∇soury∇宅2000 Ж∇setum∇新品未使用のお品となります。 Ж∇saizu∇ Ж∇kateg∇ Ж∇kaisi∇200000 Ж∇sokke∇ 足りない項目がありますよね!!そうですJANコード・ISBNコードが正しく置換できてません!!

フームー母さんのコメント
投稿がうまくいきませんでした。 >|vb| 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の方がいいかも…。 マイクロソフトの方は¥の記号が\に置き換わってる可能性あるので…。度々すいません。

naranara19さんのコメント
ありがとうございます。 はりつけまでいけました。 しかし、貼付後に、∇shina∇や、∇namae∇など、各先頭項目がすべて張り付いてしまいまして、 これが困っております。あと、▽は結構使うことが多く、Жのような使わない他の文字はございませんでしょうか?

フームー母さんのコメント
先頭の項目名が削除されませんか。何ででしょうね。 >|vb| Cells.Replace what:="∇?????∇", Replacement:="" ''?ラベルを削除 ||< ↑このコードを削除して代わりに下記のコードを入れてみてください。 >|vb| ''?ラベルを削除 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(マクロを編集するときに出てくるアプリケーション)の上部にある 編集→置換の画面で∇をЮでも何でも任意の記号に変えてください。(「すべて置換」より「置換」の方がひとつずつ目視で確認できるのでお勧め) 記号エラー処理も含めてコード内すべての∇が任意の記号に置き換わります。簡単な作業かと私は思いますが、どうしても難しいようなら置換したコードを追記します。その場合は希望する記号を指定してください。

naranara19さんのコメント
ありがとうございました!Replaceのところだけ変えてみたのですが、やっぱり削除できませんでした。これはうまくできないことがよくあるようですね。

フームー母さんのコメント
うまくいかない原因が不明です…。コードの「'配列の最初が∇namae∇なら」の行の部分 Cells(r, 1).Offset(1, 0) = arr2(i) を →Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8)にすれば、Replaceを使わなくてもいけます。 具体的に言うと。 >|vb| If InStr(arr2(i), "∇namae∇") = 1 Then '配列の最初が∇namae∇なら Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8) 'A列へ8文字目以降を転記(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列へ8文字目以降を転記(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 "エラー。読み取りデータが11の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。" End If End Sub ||< r = i ¥ 11 + 1の下の部分、後半をごっそり上記コードに入れ替えてください。 ?を削除し、振り分けのコードを変えてます。

フームー母さんのコメント
こちらでは元データが確認できないため、エラー処理をわざわざ3つ設定してあります。こちらで決めた規則に元データが合致しなければ処理しないようにしてます。(本当は間違ってるのにもっともらしいデータができても困りますよね)そのため「うまくいかない」と感じられるのかもしれません。原因が分かれば修正は簡単だと思いますよ?。 ちなみに?のReplaceがうまくいかなかった原因が、私には分かりませんでした。 セルの各先頭が全て∇namae∇などになったままっていうことですよね? 後学のために質問なんですが、 A1セルに、 あいうえおかきくけこ 書いた状態で下記マクロを作動しても全然変わりません?もしよければ教えてください。 Sub aiueo() Cells.Replace what:="あいうえお", Replacement:="" End Sub

質問者から

すみませんでした。
画像は「ファイルなう」にアップロードいたしました。
pngファイルですので、安全です。

よろしくお願いいたします。

【画像】
https://d.kuku.lu/7bbeae81b4


2 ● 空腹おやじ
●100ポイント

細かい部分の仕様がよくわからないので、
・クリップボードから取得したデータ
・データの先頭にある番号
・データを書き込む行
を指定して書き込むサンプルということで・・・

どうやって該当データを取り出して、
どうやって格納セルを設定するか
の参考になりますかね?

クリップボードからデータを取得するあたりは端折っているので
そのあたりは適当に細工して、うまく「addDatas」に渡してやってください。

Option Explicit

'参照設定:正規表現用
'Microsoft VBScript Regular Expressions 5.5


'データを書き込むワークシート名
Private Const TARGET_SHEET_NAME As String = "Sheet1"

'項目数
Private Const KEYS_COUNT As Long = 11


Public Sub test()

 Dim sSampleData As String

  'クリップボードから取り出したと想定したデータ
 sSampleData = "502(517)" & vbCrLf & _
 "1名前書森県産" & vbCrLf & _
 "1品物りんご" & vbCrLf & _
 "1JANコード・ISBNコード12345" & vbCrLf & _
 "1自社カテゴリ果物" & vbCrLf & _
 "1保管場所A9" & vbCrLf & _
 "1送料宅配便1000" & vbCrLf & _
 "1説明糖度の高い、超お勧め品です。" & vbCrLf & _
 vbCrLf & _
 "1サイズ120" & vbCrLf & _
 "1カテゴリ678" & vbCrLf & _
 "1開始価格3000" & vbCrLf & _
 "1即決価格3500" & vbCrLf & _
 vbCrLf

 sSampleData = sSampleData & "503(518)" & vbCrLf & _
 "32名前愛媛県産" & vbCrLf & _
 "32品物みかん" & vbCrLf & _
 "32JANコード・ISBNコード23456" & vbCrLf & _
 "32自社カテゴリ果物" & vbCrLf & _
 "32保管場所B2" & vbCrLf & _
 "32送料宅配便800" & vbCrLf & _
 "32説明訳あり品ですが、甘くてお勧めです" & vbCrLf & _
 "32サイズ100" & vbCrLf & _
 "32カテゴリ234" & vbCrLf & _
 "32開始価格2000" & vbCrLf & _
 "32即決価格2200"

 Call addDatas(sSampleData, 1, 2)  '先頭の番号が"1"のデータを、2行目に書き込む
 Call addDatas(sSampleData, 3, 4)  '先頭の番号が"3"のデータがないので書き込まれない
 Call addDatas(sSampleData, 32, 5)  '先頭の番号が"32"のデータを、5行目に書き込む

End Sub

'sRecordData:クリップボードから取り出した文字列データ
'lNo :各行の先頭にある数値
'lRow :ワークシートへ書き込む行
Public Sub addDatas(ByVal sRecordData As String, ByVal lNo As Long, ByVal lRow As Long)

 Dim sTitles() As String
 Dim sColumns() As String
 Dim ws As Worksheet
 Dim re As RegExp
 Dim mc As MatchCollection
 Dim i As Long

 Call getTitleAndColumnDatas(sTitles, sColumns)

 Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

 Set re = New RegExp

 re.MultiLine = True

 For i = 0 To KEYS_COUNT - 1
  '検索するパターンの設定(先頭から、指定番号の後に指定したタイトルとなっている行)
 re.Pattern = "^" & CStr(lNo) & sTitles(i) & "(.+)\r\n"
 Set mc = re.Execute(sRecordData)

 If mc.Count = 1 Then
  'マッチするデータがあればワークシートに書き込む
 ws.Range(sColumns(i) & CStr(lRow)).Value = mc.Item(0).SubMatches(0)
 End If
 Next i

End Sub

'クリップボードから取り出した文字列データのタイトルと格納する列のデータを設定
Private Sub getTitleAndColumnDatas(ByRef sTitles() As String, ByRef sColumns() As String)

  '項目を追加、削除する場合は、上の方で宣言しているKEYS_COUNTの値の変更も忘れないこと
 ReDim sTitles(KEYS_COUNT - 1)
 ReDim sColumns(KEYS_COUNT - 1)

 sTitles(0) = "名前"
 sColumns(0) = "A"

 sTitles(1) = "品物"
 sColumns(1) = "C"

 sTitles(2) = "JANコード・ISBNコード"
 sColumns(2) = "AK"

 sTitles(3) = "自社カテゴリ"
 sColumns(3) = "D"

 sTitles(4) = "保管場所"
 sColumns(4) = "E"

 sTitles(5) = "送料"
 sColumns(5) = "H"

 sTitles(6) = "説明"
 sColumns(6) = "I"

 sTitles(7) = "サイズ"
 sColumns(7) = "J"

 sTitles(8) = "カテゴリ"
 sColumns(8) = "N"

 sTitles(9) = "開始価格"
 sColumns(9) = "T"

 sTitles(10) = "即決価格"
 sColumns(10) = "BM"

End Sub

naranara19さんのコメント
ありがとうございます! コンパイルエラー ユーザ定義型は定義されていません。 と出てしまい、 Public Sub addDatas(ByVal sRecordData As String, ByVal lNo As Long, ByVal lRow As Long) で止まってしまうのです。

空腹おやじさんのコメント
参照設定を行っていない為だと思われます。 以下のリンク先の「事前の準備」を参考にして Microsoft VBScript Regular Expressions 5.5 にチェックをいれてから、再度実行してみてください。 [https://codezine.jp/article/detail/1655:title]

naranara19さんのコメント
すみませんでした。参照したあと実行しますと、 インデックスが有効範囲にありません。 とエラーが出てしまいます。
関連質問

●質問をもっと探す●



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