【ｴｸｾﾙVBAﾏｸﾛ】ｴｸｾﾙ内の改行された内容から部分部分を切り取って貼り付けたい｡ 1行目に見出しの入ったｴｸｾﾙｼｰﾄがあります｡ D列のｾﾙ内容が改行されて…

以下のｺｰﾄﾞを標準ﾓｼﾞｭｰﾙに貼り付けて､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