住所録を作成しています。以下のような文字列が数百件分あります。


これを、エクセルで以下のような状態にする為の方法をお願いします。

○○○○○○

住所 〒123-4567 ○○県○○市○○町12-345 ●●●●●

TEL 03-1234-4567

●●●●●●●●●●●●●●

△△△△△△

住所 〒765-4321 △△県△△市△△町12-345 ●●●●●

TEL 06-1234-4567

●●●●●●●●●●●●●●

・記載のまま実データには、改行が含まれています。
・記載のまま実データには、半角or全角スペースが含まれています。
・記載のまま実データには、●●●という固定の文字列を含みます。
・記載のまま実データには、「住所」「TEL」「〒」という固定の文字列を含みます。

↑これを、以下のように↓
○○○○○○ 123-4567 ○○県○○市○○町12-345 03-1234-4567
△△△△△△ 765-4321 △△県△△市△△町12-345 06-1234-4567

・セル区切りで以下の項目で、一行づつに
・「〒」の文字列は必要ありません。
・「住所」の文字列は必要ありません。
・「TEL」の文字列は必要ありません。
・●●の部分の文字列は不要です。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/05/16 12:53:34
  • 終了:2013/05/16 15:38:39

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982013/05/16 15:17:37

ポイント500pt

元の文字列が どういう状態かわからないため、二通り 作ってみました。


一つのセルに データが 入っている場合

Sub main()

    元シート = "Sheet1"
    セットシート = "Sheet2"
    
    Worksheets(セットシート).Cells.Delete Shift:=xlUp
    
    Dim a As Long
    Dim b As Long
    
    b = 1
    For a = 1 To Worksheets(元シート).Cells(Rows.Count, "A").End(xlUp).Row
        c2 = Worksheets(元シート).Cells(a, "A")
        
        If Left(c2, 2) = "住所" Then
            Worksheets(セットシート).Cells(b, "A") = c1
            Worksheets(セットシート).Cells(b, "B") = Right(Left(c2, 12), 8)
            c2 = Right(c2, Len(c2) - 13)
            c3 = Left(c2, InStr(c2 & " ", " "))
            c3 = Left(c3, InStr(c3 & " ", " "))
            
            Worksheets(セットシート).Cells(b, "C") = Trim(c3)
        Else
            If Left(c2, 3) = "TEL" Then
            Worksheets(セットシート).Cells(b, "D") = Right(c2, Len(c2) - 4)
            b = b + 1
            
            Else
                If Trim(c2) <> "" Then
                    c1 = c2
                End If
            End If
        End If
    Next a
End Sub



それぞれ項目ごと セルが分かれている場合、

Sub main()

    元シート = "Sheet3"
    セットシート = "Sheet4"
    
    Worksheets(セットシート).Cells.Delete Shift:=xlUp
    
    Dim a As Long
    Dim b As Long
    
    b = 1
    For a = 1 To Worksheets(元シート).Cells(Rows.Count, "A").End(xlUp).Row
        c2 = Worksheets(元シート).Cells(a, "A")
        
        If c2 = "住所" Then
            Worksheets(セットシート).Cells(b, "A") = c1
            c4 = Worksheets(元シート).Cells(a, "B")
            Worksheets(セットシート).Cells(b, "B") = Right(c4, 8)
            Worksheets(セットシート).Cells(b, "C") = Worksheets(元シート).Cells(a, "C")
        Else
            If c2 = "TEL" Then
            Worksheets(セットシート).Cells(b, "D") = Worksheets(元シート).Cells(a, "B")
            b = b + 1
            
            Else
                If Trim(c2) <> "" Then
                    c1 = c2
                End If
            End If
        End If
    Next a
End Sub



それぞれ
元シート = "Sheet1"
セットシート = "Sheet2"
の箇所を変更して使ってみてください。

id:surippa20

セルが一つにまとまっていることをお伝えし忘れました。お手数をおかけいたしました。
マクロは正常に動作し、希望通りの住所録になりました。
早々に回答いただき大変助かりました。
ありがとうございました。

2013/05/16 15:38:33

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

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

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

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

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