住所禄を作成しています。今回も以下のように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>

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/02/01 18:13:39
  • 終了:2013/02/02 18:13:52

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/02/01 18:58:43

ポイント250pt
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"

他4件のコメントを見る
id:taknt

もう一度 確認してみてください。

2013/02/02 17:51:33
id:surippa20

再度、ありがとうございます。たしかに、その通りかもしれません。(住所の行のすぐ真上に必ずある、ということぐらいでしょうか)作業的には大変に助かりました。ありがとうございました。

2013/02/02 18:12:39

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/02/01 18:58:43ここでベストアンサー

ポイント250pt
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"

他4件のコメントを見る
id:taknt

もう一度 確認してみてください。

2013/02/02 17:51:33
id:surippa20

再度、ありがとうございます。たしかに、その通りかもしれません。(住所の行のすぐ真上に必ずある、ということぐらいでしょうか)作業的には大変に助かりました。ありがとうございました。

2013/02/02 18:12:39
id:oil999 No.2

oil999回答回数1728ベストアンサー獲得回数3202013/02/01 19:32:22

ポイント250pt

「この○○は、無いものもあります」という条件を見落としていました。
プログラムを修正したので、お試しください。
変換元のシートは変数 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
id:surippa20

早々にありがとうございます。
ためして見ましたが、殆どうまく走りませんでした。
空白行の位置がランダムの為、こうなってしまうのでしょうか。

A社 <TEL> < 2
B社 <TEL> < 2
C社 <TEL> < 2
備考2 <> < 会社
D社 <TEL> < 1
E社 <TEL> < 2

2013/02/02 11:11:57
id:oil999

「この○○は、無いものもあります」という条件を見落としていました。
プログラムを修正したので、お試しください。

2013/02/02 12:00:48
id:pigmon88 No.3

pigmon88回答回数501ベストアンサー獲得回数252013/02/01 23:29:53

ポイント50pt

人にいちいちきくより、sedをマスターしてください。

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

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

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

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

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