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

【エクセルVBAマクロ】エクセル内の改行された内容から部分部分を切り取って貼り付けたい。


1行目に見出しの入ったエクセルシートがあります。

D列のセル内容が改行されているのですが、その改行ごとに必要なデータを同じ行の別のセルに貼り付けたいと思っています。



詳しくは画像をご確認ください。


不明な部分はご質問いただければ幸いです。



マクロ作成以外にはポイントをおつけできませんので、
あらかじめご了承くださいませ。

1458532793
●拡大する

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

▽最新の回答へ

1 ● a-kuma3
●500ポイント ベストアンサー

以下のコードを標準モジュールに貼り付けて、parse_order サブルーチンを実行してください。

Sub parse_order()
  ' データの切り出し方の定義
 Dim def(5, 2)
 def(0, 0) = "0": def(0, 1) = "N": def(0, 2) = "(.*)"
 def(1, 0) = "1": def(1, 1) = "O": def(1, 2) = "(.*)"
 def(2, 0) = "5": def(2, 1) = "H": def(2, 2) = "〒(\d{3}-\d{4})"
 def(3, 0) = "5": def(3, 1) = "J": def(3, 2) = "〒\d{3}-\d{4} ([^都道府県]+[都道府県])"
 def(4, 0) = "5": def(4, 1) = "L": def(4, 2) = "〒\d{3}-\d{4} [^都道府県]+[都道府県](.*)"
 def(5, 0) = "6": def(5, 1) = "F": def(5, 2) = "(.*)様?$"

  ' データの切り出し
 last_row = Cells(Rows.Count, 4).End(xlUp).Row
 For r = 2 To last_row
 Data = Split(Cells(r, 4).Value, vbLf)

  ' 最低でも 6行は必要
 If UBound(Data) >= 6 Then
 For i = LBound(def) To UBound(def)
 Line = Val(def(i, 0))
 Set re = CreateObject("VBScript.RegExp")
 re.Pattern = def(i, 2)
 Set Match = re.Execute(Data(Line))
 If (Match.Count > 0) Then
 Range(def(i, 1) & r).Value = Match(0).submatches(0)
 End If
 Next
 End If
 Next
End Sub

データの切り出し方を配列で定義しています。

データについては、以下のことを前提としています。


追記です。
コメントにあった実際の D列のデータで定義を調整してみました。

Sub parse_order()
  ' データの切り出し方の定義
 Dim def(5, 2)
 def(0, 0) = "0": def(0, 1) = "N": def(0, 2) = "(.*)"
 def(1, 0) = "2": def(1, 1) = "BJ": def(1, 2) = "(.*)"
 def(2, 0) = "9": def(2, 1) = "L": def(2, 2) = "〒(\d{3}-\d{4})"
 def(3, 0) = "9": def(3, 1) = "M": def(3, 2) = "〒\d{3}-\d{4} ([^都道府県]+[都道府県])"
 def(4, 0) = "9": def(4, 1) = "N": def(4, 2) = "〒\d{3}-\d{4} [^都道府県]+[都道府県](.*)"
 def(5, 0) = "10": def(5, 1) = "F": def(5, 2) = "(.*)( 様$)"

  ' データの切り出し
 last_row = Cells(Rows.Count, 4).End(xlUp).Row
 For r = 2 To last_row
 Data = Split(Cells(r, 4).Value, vbLf)

  ' 最低でも 10行は必要
 If UBound(Data) >= 10 Then
 For i = LBound(def) To UBound(def)
 Line = Val(def(i, 0))
 Set re = CreateObject("VBScript.RegExp")
 re.Pattern = def(i, 2)
 Set Match = re.Execute(Data(Line))
 If (Match.Count > 0) Then
 Range(def(i, 1) & r).Value = Match(0).submatches(0)
 End If
 Next

  ' D列をクリア
 Cells(r, 4).Value = ""
 End If
 Next
End Sub



追記です。

(1)のデータのみBI列に貼り付けられないようです。

ごめんなさい。コメントで「BI列に」とあったのを見落としていました。
以下のコードで試してみてください。

Sub parse_order()
  ' データの切り出し方の定義
 Dim def(5, 2)
 def(0, 0) = "0": def(0, 1) = "BI": def(0, 2) = "(.*)"
 def(1, 0) = "2": def(1, 1) = "BJ": def(1, 2) = "(.*)"
 def(2, 0) = "9": def(2, 1) = "L": def(2, 2) = "〒(\d{3}-\d{4})"
 def(3, 0) = "9": def(3, 1) = "M": def(3, 2) = "〒\d{3}-\d{4} ([^都道府県]+[都道府県])"
 def(4, 0) = "9": def(4, 1) = "N": def(4, 2) = "〒\d{3}-\d{4} [^都道府県]+[都道府県](.*)"
 def(5, 0) = "10": def(5, 1) = "F": def(5, 2) = "(.*)( 様$)"

  ' データの切り出し
 last_row = Cells(Rows.Count, 4).End(xlUp).Row
 For r = 2 To last_row
 Data = Split(Cells(r, 4).Value, vbLf)

  ' 最低でも 10行は必要
 If UBound(Data) >= 10 Then
 For i = LBound(def) To UBound(def)
 Line = Val(def(i, 0))
 Set re = CreateObject("VBScript.RegExp")
 re.Pattern = def(i, 2)
 Set Match = re.Execute(Data(Line))
 If (Match.Count > 0) Then
 Range(def(i, 1) & r).Value = Match(0).submatches(0)
 End If
 Next

  ' D列をクリア
 Cells(r, 4).Value = ""
 End If
 Next
End Sub

naranara19さんのコメント
いつもありがとうございます。 やってみたのですが、実際の他のデータが邪魔してうまく入れ替えの貼付ができて おりません(私のスキル不足です) 実際の形は、下記のようになります。最後につけた()内の形が段数です (2)は何も入っていないということになります。 160314403(1) (2) りんご1箱青森県産(3) 商品代金¥2000(4) 販売手数料¥300(5) 販売利益¥1700(6) 送料送料込み(店側負担)(7) 購入日時3月19日 24:00(8) 商品IDmoi123(9) お届け先〒000-0000 東京都千代田区本町1-1-1(10) 販売太郎 様(11) (1)をBI列に(マクロをかけるとすべて残ったままになりますので、切り取り後のD列データはすべて空白にしていただけますでしょうか) (3)はBJ列に (10)の郵便番号はL列に (10)の都道府県はM列に (10)の残り住所はN列に (11)の氏名はF列に お願いしたいのです。 再度整理する必要があるかと思いますので、当然ポイント加算させていただきます。 いつもお手数をおかけして申し訳ございません。

a-kuma3さんのコメント
回答に追記しました。

naranara19さんのコメント
ありがとうございました。(1)のデータのみBI列に貼り付けられないようです。こちらのみ、最後お願いできますでしょうか?他はしっかりと動いております。感謝です。

a-kuma3さんのコメント
>> (1)のデータのみBI列に貼り付けられないようです。 << ごめんなさい。コメントで「BI列に」とあったのを見落としていました。 回答に追記したので、そちらのコードで試してみてください。

naranara19さんのコメント
いえいえ、こちらがお手数をおかけしておりますので。いつも事後フォローがきちんとしてくださって、大変感謝しております!完璧に動作いたしました。本当に感謝いたします!

naranara19さんのコメント
【追加依頼 ポイントは送信いたします】 先日はありがとうございました。 こちらの加工をお願いできますでしょうか? 4行目の 商品代金 ¥2000(4) をAI列に\マークをとった2000を数値のみで挿入できるようにしていただきたいのです。 なお、最後の(4)は便宜上つけたのみで、実際にはございません。 やっていただけましたら、a-kuma3さんに、確実に200Pを送信いたします。 お手数をおかけしますが、よろしくお願い申し上げます。

naranara19さんのコメント
マークは円マークのことです。お手数をおかけしますが、お気づきでしたらよろしくお願い申し上げます。
関連質問

●質問をもっと探す●



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