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



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

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



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


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



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

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2016/03/21 12:59:53
  • 終了:2016/03/22 03:47:48

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4324ベストアンサー獲得回数17732016/03/21 15:54:40

ポイント500pt

以下のコードを標準モジュールに貼り付けて、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

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

  • def(*, 0) : D列の何行目が対象か。文字列で数字を指定します。先頭行が 0行目です。
  • def(*, 1) : 切り取ったデータをどの列に設定するか。英文字です。
  • def(*, 2) : データの切り出しを行う正規表現。

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

  • 郵便番号は「半角の数字3ケタ」+「半角のハイフン」+「半角の数字3ケタ」
  • 郵便番号の後に半角の空白がひとつある
  • 都道府県は必ず記載されている(省略されていない)
  • 注文者氏名の「様」の直後に改行、もしくはデータの終わりがある



追記です。
コメントにあった実際の 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
他5件のコメントを見る
id:naranara19

【追加依頼 ポイントは送信いたします】

先日はありがとうございました。
こちらの加工をお願いできますでしょうか?

4行目の
商品代金 ¥2000(4)

をAI列に\マークをとった2000を数値のみで挿入できるようにしていただきたいのです。
なお、最後の(4)は便宜上つけたのみで、実際にはございません。

やっていただけましたら、a-kuma3さんに、確実に200Pを送信いたします。
お手数をおかけしますが、よろしくお願い申し上げます。

2016/09/23 10:57:52
id:naranara19

マークは円マークのことです。お手数をおかけしますが、お気づきでしたらよろしくお願い申し上げます。

2016/09/23 10:58:28

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません