質問: 不規則なフォーマットのメール内容をエクセルに抽出したいのですが、どなた 不規則なフォーマットのメール内容をエクセルに抽出したいのですが、どなたかお教えいただけませんでしょうか。 小さな会社でメール問い合わせの受付をしています。 現在はポータルサイト経由で来たメールの内容をエクセルの表に転記しているのですが、 以前から使っていたポータルからのメールはフォーマットが決まっているため、メール本文から必要なところをコピーし、決まったセルにそのまま貼り付け、mid関数やlenを使って名前や住所など、必要な情報を別の場所に抜き出し、それを自動マクロを駆使して別のワークシートにある表にコピーする方法で何とか自動化することができていました。 ところが、最近加入したポータル経由の問い合わせメールは、項目の上から順に入力のあったところだけが表示されていて行数がバラバラなので、上記の方法が使えません。 例1) 問い合わせ番号:0000001 お名前:○山○子 メールアドレス:aaa@aaa.com 詳しい内容:掲載の商品について教えて欲しいのですが 一番気になるのは写真が掲載されているもので、2番目 に気になるのは価格が一番安いものです。 どの商品が一番人気か教えてもらえませんか? ご希望の連絡方法:メール 年代・性別:30代女性 例2) 問い合わせ番号:0000002 お名前:△原△雄 お電話番号:00000000000 fax番号:0000000000 メールアドレス:bbb@bbb.co.jp 住所:大阪府*********** 詳しい内容:商品がすぐ欲しいので一度電話で連絡ください ご希望の連絡方法:電話 ご希望の商品:******** 年代・性別:40代男性 といった感じで、「問い合わせ番号」と「お名前」「詳しい内容」以外は 項目があったり無かったりして、行数も場所も定まりません。 さらに「詳しい内容」の欄は文字数が決まっていないため、 何行にもわたる場合があります。 現在は1項目ごとにコピぺでエクセルの表に転記しているのですが、とても大変なのと、ミスをしそうで怖いので、なんとかvbaを使ってエクセルへ取り込みたいのです。 しかしなにぶん自動マクロを駆使する程度のスキルのため、どうすればいいのかさっぱりわかりません。 どなたか良い方法をお教えいただけませんでしょうか。
回答: こんにちは セルの位置などの具体的な内容がほしかったのですが、位置関係が分からないので、以下のマクロを加工してくださるようにお願いします。パターンは、定型句を使っていることが条件ですから、それが違っているとヒットしません。また、こちらは、goo 側から回答していますので、半角和字が使用できませんので、代用のワイルドカードの文字(.)を使っています。例えば、年代・性別の間の、中黒点は全角でも半角でもヒットするように作られています。 sheet1 のa1 に貼り付けたものを、sheet2 のa1 に別けて貼りつけます。 なお、「問い合わせ番号」は、0も取れていますが、貼付けの際に「数値」に変わってしまうので、0がなくなってしまいます。書式の文字列にしてください。それができないなら、マクロで処理します。 この文字列を取得するマクロは、慣れている人なら簡単ですが、いくつかのポイントの勉強が必要になります。 '------------------------------------------- sub pickupdata() dim patterns(8) as string dim datas(8) as string dim matches as object dim c as range dim i as variant dim buf as string dim sh as worksheet set sh = worksheets("sheet1") 'パターン群 patterns(0) = "問い合わせ番号:(\d+)" patterns(1) = "お名前.(.+)$" patterns(2) = "詳しい内容.(.+)$" patterns(3) = "お電話番号.([\d\-]+)$" patterns(4) = "メールアドレス.(.+)$" patterns(5) = "住所.(.+)$" patterns(6) = "ご希望の連絡方法.(.+)$" patterns(7) = "ご希望の商品.(.+)$" patterns(8) = "年代.性別.(.+)$" with createobject("vbscript.regexp") application.screenupdating = false for i = 0 to ubound(patterns) .pattern = patterns(i) .global = false for each c in sh.range("a1", sh.range("a18")) if c.value <> "" then set matches = .execute(c.text) if matches.count > 0 then if i = 2 then buf = matches(0).submatches(0) buf = buf & vblf & combinetext(c) datas(i) = buf else datas(i) = matches(0).submatches(0) exit for end if end if end if next c next i application.screenupdating = true end with '貼付け先 worksheets("sheet2").range("a1").resize(9).value = application.transpose(datas) set sh = nothing end sub function combinetext(c as range) dim j as long dim buf as string with activesheet for j = 1 to cells(c.rows.count, c.column).end(xlup).row buf = buf & vblf & c.offset(1).text next j end with combinetext = buf end function