住所禄を作成しています｡今回も以下のように1社一行のｴｸｾﾙﾃﾞｰﾀを作成したいのですが､ A社郵便番号住所 TEL 今回の手元にあるﾃﾞｰﾀは以下のようなものが並ん…

住所禄を作成しています｡今回も以下のように1社一行のｴｸｾﾙﾃﾞｰﾀを作成したいのですが､

A社郵便番号住所 TEL

今回の手元にあるﾃﾞｰﾀは以下のようなものが並んでいます｡

<A社>
(空白行)
○○○○○
<住所><〒103-0000 東京都中央区○○1丁目>
<TEL><03-1234-5678>
(空白行)
<HP>
(空白行)
<E-mail>
(空白行)
<備考1>
(空白行)
<備考2>
(空白行)
(空白行)

と､
○○の文字数はﾗﾝﾀﾞﾑで､1行です｡位置は必ず<住所>の1つ上の行です｡
この○○は､無いものもあります｡
空白行の行数は､多いものもあれば無いものもあります｡
HP､E-mail､備考1､備考2､の項目自体が､あるものとないものがあります｡
これらの4項目の右側には､文字があるものとないものがあります｡

｢〒｣のﾏｰｸは不要ですが､元には含まれています｡
〒103-0000と東京都中央区○○1丁目の間には､全角ｽﾍﾟｰｽが1つあります｡
<〒103-0000 東京都中央区○○1丁目>は1ｾﾙです｡

この元のﾃﾞｰﾀを1社一行で､以下のような4つのｾﾙにする為の
ﾏｸﾛを教えて下さい｡

<A社><103-0000><東京都中央区○○1丁目><03-1111-1111>

Sub 実行()
Dim b As Long
Dim c As Long

 元ｼｰﾄ = "Sheet1"
 作成先ｼｰﾄ = "Sheet2"
 
 a = Sheets(元ｼｰﾄ).Cells(Rows.Count, "A").End(xlUp).Row
 k = 1
 c = 1
 For b = 1 To a
 d = Sheets(元ｼｰﾄ).Cells(b, "A")
 If d <> "" Then
 
 If InStr(d, "住所") > 0 Then
 
 For bb = b - 1 To 1 Step -1
 If Left(Sheets(元ｼｰﾄ).Cells(bb, "A"), 1) <> "○" Then
 If Sheets(元ｼｰﾄ).Cells(bb, "A") <> "" Then
 d2 = Sheets(元ｼｰﾄ).Cells(bb, "A")
 Exit For
 End If
 End If
 Next bb
 
 Sheets(作成先ｼｰﾄ).Cells(c, 1) = d2
 
 e = Sheets(元ｼｰﾄ).Cells(b, "B")
 e1 = InStr(e, " ")
 e2 = Replace(Left(e, e1), "〒", "")
 e3 = Right(e, Len(e) - e1)
 Sheets(作成先ｼｰﾄ).Cells(c, 2) = e2
 Sheets(作成先ｼｰﾄ).Cells(c, 3) = e3
 Sheets(作成先ｼｰﾄ).Cells(c, 4) = Sheets(元ｼｰﾄ).Cells(b + 1, "B")
 c = c + 1
 e0 = ""
 End If
 End If
 Next b
End Sub

ﾃﾞｰﾀがあるｼｰﾄを元ｼｰﾄとしていますのでそこにそのｼｰﾄ名､
新規に作成するのを作成先ｼｰﾄとしていますのでそこに新規で作成する側のｼｰﾄ名を入れてください｡
ｼｰﾄは作成しておいてください｡
また､作成先ｼｰﾄは上書きされます｡

元ｼｰﾄ = "Sheet1"
作成先ｼｰﾄ = "Sheet2"

｢この○○は､無いものもあります｣という条件を見落としていました｡
ﾌﾟﾛｸﾞﾗﾑを修正したので､お試しください｡
変換元のｼｰﾄは変数 sour に､変換先のｼｰﾄは変数 dest に指定してください｡

Sub main()
 Dim v As Variant
 Dim sour, dest As String
 Dim i, j, n, ln As Long
 sour = "Sheet1"
 dest = "Sheet2"

 ln = Worksheets(sour).Cells(Rows.Count, "A").End(xlUp).row
 i = 1
 j = 1
 While (i <= ln)
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  '会社名
 Worksheets(dest).Cells(j, 1).Value = v
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  '郵便番号
 n = InStr(v, "〒")
 if (n = 0) Then
 v = Worksheets(sour).Cells(i, 1).Value
 End If
 Worksheets(dest).Cells(j, 2).Value = "<" & Mid(v, n + 1, 8) & ">"
  '住所
 Worksheets(dest).Cells(j, 3).Value = "<" & Mid(v, n + 10)
 i = i + 1
 v = Worksheets(sour).Cells(i, 1).Value
  '電話番号
 Worksheets(dest).Cells(j, 4).Value = Mid(v, 6)
 i = i + 1
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  'HP
  'Worksheets(dest).Cells(j, 5).Value = v
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  'E-mail
  'Worksheets(dest).Cells(j, 6).Value = v
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  '備考1
  'Worksheets(dest).Cells(j, 7).Value = v
  '空白ｽｷｯﾌﾟ
 Do
 v = Worksheets(sour).Cells(i, 1).Value
 i = i + 1
 Loop While (v = "" And i <= ln)
  '備考2
  'Worksheets(dest).Cells(j, 8).Value = v
 j = j + 1
 Wend
End Sub