こんにちは
セルの位置などの具体的な内容がほしかったのですが、位置関係が分からないので、以下のマクロを加工してくださるようにお願いします。パターンは、定型句を使っていることが条件ですから、それが違っているとヒットしません。また、こちらは、Goo 側から回答していますので、半角和字が使用できませんので、代用のワイルドカードの文字（.）を使っています。例えば、年代・性別の間の、中黒点は全角でも半角でもヒットするように作られています。
Sheet1 のA1 に貼り付けたものを、Sheet2 のA1 に別けて貼りつけます。
なお、「問い合わせ番号」は、０も取れていますが、貼付けの際に「数値」に変わってしまうので、０がなくなってしまいます。書式の文字列にしてください。それができないなら、マクロで処理します。
この文字列を取得するマクロは、慣れている人なら簡単ですが、いくつかのポイントの勉強が必要になります。
'-------------------------------------------
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
お礼
御礼が遅くなり申し訳ありません！ こちらがあいまいな表現でお伝えしていたにもかかわらず、 完璧なコードを書いてくださり、ありがとうございます。 心から感謝しております！！！ 本当に助かりました。どうもありがとうございました。 <(_ _*)> ))
補足
ご回答ありがとうございます。 書き方がまずくてすみません。 >例1)のようなスタイルが問題だとおっしゃっているのですか？ >例2)も問題だとおっしゃっているのですか？ これはまず例1)と例2)が混在している事が問題と感じています。 従来から使っているものは、 氏名：＊＊＊＊ メールアドレス：＊＊＊＊ 電話番号：＊＊＊＊ ・ ・ ・ 問い合わせ内容：＊＊＊＊ という順番が固定しており、空白があっても項目数･･･つまり行数は変わらないので、 メール本文の必要な部分をコピーし、エクセルの決まったセルに貼り付けると、決まった行に決まった項目が入ります。 そこからMID関数などで「氏名：」「メールアドレス：」を省いたものを、別シートに作った一番上の列がタイトル行になっている、よくある一覧表の下にマクロで貼り付けています。 （問い合わせ内容はこちらも文字数不定ですが、一番下なので、そこだけ別にコピーをして特定のセルへ貼り付けています。） しかしその方法では決まった行に決まった項目が入らないと使えませんので、どうすればいいのか分からず、新しい方のメールはまだマクロを組んでおりません。 現在は従来のものとは別シートで、同じように一番上の列がタイトル行の表を作り、下に名前やメールアドレスなどの項目を一つずつ手作業で貼り付けています。 このような説明でお分かりいただけますでしょうか。 実はＶＢＡも勉強しようと思って独学で取り組んではみたのですが、まず基礎すらあいまいな状態では配列がどうしても理解できないのと、エラー処理、繰り返し処理など、勉強しなければいけないことが山ほどあるようで挫折してしまい、ここに投稿させていただいたのです。時間をかけて学んで行くにしてもハードルが高すぎて、今実務で必要なものを作るには間に合わないのです。 どうかお助けくださいますようお願い致します。