住所禄を作成しています。一般的な以下のように1行に一社にしたいのですが、


A社 郵便番号 住所 TEL

現在、手元にあるデータが、

A社
住所  103-0000東京都中央区○○1丁目
TEL  03-1234-5678

と3行にわたり、5つのセルのデータです。
このデータを1行で、以下のようにする為の、
マクロを教えて下さい。

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/01/25 18:31:46
  • 終了:2013/01/26 01:46:56

ベストアンサー

id:oil999 No.2

oil999回答回数1728ベストアンサー獲得回数3202013/01/25 18:58:48

ポイント300pt

郵便番号と住所が1つのセルに入っていて、これを分離するという前提です。
変換元のシートは変数 sour に、変換先のシートは変数 dest に指定してください。

コメント

各会社の間に、空白行があり、そこで止まってしまいました。空白行は、1行のものもあれば2行のものもあります。
自分自身で省けるか少しやってみます。もし解決策がありましたらお願いいたします。

を受けて、マクロを変更しました。
お試しください。

Sub main()
  Dim v As Variant
  Dim sour, dest As String
  Dim i, j, 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
      v = Worksheets(sour).Cells(i, 2).Value
      Worksheets(dest).Cells(j, 2).Value = Left(v, 8)
      Worksheets(dest).Cells(j, 3).Value = Mid(v, 9)
      i = i + 1
      v = Worksheets(sour).Cells(i, 2).Value
      Worksheets(dest).Cells(j, 4).Value = v
      i = i + 1
      j = j + 1
  Wend
End Sub

他1件のコメントを見る
id:oil999

コメントを受けて、回答のマクロを修正しました。
お試しください。

2013/01/25 21:58:28
id:surippa20

早々に大変助かります。
できました。ありがとうございました。

2013/01/25 23:20:51

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982013/01/25 18:58:29

ポイント100pt
Sub test()
    Dim 開始行 As Long
    Dim a As Long
    
    開始行 = 1
    
    For a = 1 To Rows.Count
        If Cells(a, "A") = "" Then Exit For
        Cells(a, "B") = Cells(a + 1, "B")
        Cells(a, "C") = Cells(a + 2, "B")
        Rows(a + 2).Delete
        Rows(a + 1).Delete
       
    Next a

End Sub
id:surippa20

早々にありがとうございます。
そのままマクロに入れたのですが、うまく表示しませんでした。中身を見てみようと思います。

2013/01/25 20:08:09
id:oil999 No.2

oil999回答回数1728ベストアンサー獲得回数3202013/01/25 18:58:48ここでベストアンサー

ポイント300pt

郵便番号と住所が1つのセルに入っていて、これを分離するという前提です。
変換元のシートは変数 sour に、変換先のシートは変数 dest に指定してください。

コメント

各会社の間に、空白行があり、そこで止まってしまいました。空白行は、1行のものもあれば2行のものもあります。
自分自身で省けるか少しやってみます。もし解決策がありましたらお願いいたします。

を受けて、マクロを変更しました。
お試しください。

Sub main()
  Dim v As Variant
  Dim sour, dest As String
  Dim i, j, 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
      v = Worksheets(sour).Cells(i, 2).Value
      Worksheets(dest).Cells(j, 2).Value = Left(v, 8)
      Worksheets(dest).Cells(j, 3).Value = Mid(v, 9)
      i = i + 1
      v = Worksheets(sour).Cells(i, 2).Value
      Worksheets(dest).Cells(j, 4).Value = v
      i = i + 1
      j = j + 1
  Wend
End Sub

他1件のコメントを見る
id:oil999

コメントを受けて、回答のマクロを修正しました。
お試しください。

2013/01/25 21:58:28
id:surippa20

早々に大変助かります。
できました。ありがとうございました。

2013/01/25 23:20:51
id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982013/01/25 22:03:05

ポイント100pt

会社間に空行の対応をしました。


Sub test()
    Dim 開始行 As Long
    Dim a As Long
    Dim b As Long
    
    開始行 = 1
    b = 開始行
    
    For a = 開始行 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(b, "A") = "" Then
            Rows(b).Delete
        Else
            Cells(b, "B") = Cells(b + 1, "B")
            Cells(b, "C") = Cells(b + 2, "B")
            Rows(b + 2).Delete
            Rows(b + 1).Delete
            b = b + 1
        End If
    Next a

End Sub
他1件のコメントを見る
id:surippa20

早々に大変助かります。
表示結果は以下のようになりました。
「A社」「111-1111 東京都中央区○○1丁目」「03-1111-1111」の3セルになりました。

2013/01/25 23:16:50
id:taknt

郵便番号と住所の間に 空白が あったんですね。
見落としてました。

2013/01/28 11:00:24

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

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

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

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

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