[[20060720151847]] 『住所の分割について』(裕) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『住所の分割について』(裕)

1つのセルに都道府県〜の住所があり分割したいのですができますでしょうか?

Aセル

神奈川県横浜市神奈川区反町1−1−10

これを

Aセル

神奈川県


横浜市神奈川区(または、23区、〜市、〜郡)


それ以降

のような形にしたいのです


 こちらをご参考に。(ぷーのすけ)
     ↓
[[20040625022224]] 『住所分割方法について』(キヨ)

 住所の分割は色々制約があって一筋縄ではいけまへんなぁ。
 ところでこんなスペシアル関数はどうでっか?

 下のコードをそれぞれのモジュールにコピペ
 使い方は=yata(a1:a500)といった塩梅に書き込みます(コピペ不要)
 ただ、これにはひとつ難点がありまして、194行を超えるとエラーが出ますから
 メッセージボックスの誘導通りmacroを実行してくらはい。
     (弥太郎)
 標準モジュールへ
 '-----------------------
 Public maxrng As Long
 Public adrs_data
 Public st_adrs As String
 Public end_adrs As Long
 Public flag As Boolean
 Public adrs1
 Public sp_data
 Public tbl As Range
 Public adrs As String
 Option Base 1
 Function yata(data)
    Dim get_sty()
    Dim n As Integer, i As Integer, mid_cnt As Integer
    Dim get_data As String
    Dim city As Integer, gun As Integer

    Application.EnableEvents = True
    Set tbl = Range(data.Address(0, 0))
    If tbl.Rows.Count > 1 Then
        adrs = data.Address(0, 0)
        adrs_data = Split(adrs, ":")
        adrs1 = adrs_data(0)
        st_adrs = ActiveCell.Address(0, 0)
        end_adrs = tbl.Rows.Count
        maxrng = end_adrs
        data = Range(adrs1)
        flag = True
    ActiveCell.Formula = "=yata (" & adrs1 & ")"
    End If
    sp_data = ""
    If data = "" Then yata = "": Exit Function

    Select Case Left(data, 3)
        Case "大阪府", "京都府", "東京都", "北海道"
            sp_data = Left(data, 3) & ","
            mid_cnt = 3
        Case Else
            For i = 3 To 4
                If Mid(data, i, 1) = "県" Then
                    sp_data = Left(data, i) & ","
                    mid_cnt = i
                    Exit For
                End If
            Next i
    End Select

    get_data = Mid(data, mid_cnt + 1, 77)
    n = InStr(get_data, "市")
    city = InStr(n + 1, get_data, "市")
    gun = InStr(get_data, "郡")
    If n <> 0 Then
        If city <> 0 And city < 6 Then
            Select Case Left(get_data, city)
                Case "八日市場市", "市川市", "市原市", "今市市", "四日市市", _
                            "八日市市", "廿日市市"
                    sp_data = sp_data & Left(get_data, city) & ","
                    mid_cnt = mid_cnt + city
                Case Else
                    If Left(get_data, 3) <> "余市郡" Then
                        sp_data = sp_data & Mid(get_data, 1, n) & ","
                        mid_cnt = mid_cnt + n
                    End If
            End Select
        ElseIf gun <> 0 And n > gun Then
            If get_data Like "郡上市*" Or get_data Like "小郡市*" Or get_data Like _
                    "郡山市*" Or get_data Like "蒲郡市*" Or get_data Like "大和郡山市*" Then
                sp_data = sp_data & Mid(get_data, 1, n) & ","
                mid_cnt = mid_cnt + n
            End If
        ElseIf gun <> 0 And n < gun Then
            If Mid(get_data, 1, gun) <> "高市郡" Then
                sp_data = sp_data & Mid(get_data, 1, n) & ","
                mid_cnt = mid_cnt + n
            End If
        Else
            If n <> 1 Then
                sp_data = sp_data & Mid(get_data, 1, n) & ","
                mid_cnt = mid_cnt + n
            End If

        End If
    End If

    get_data = Mid(data, mid_cnt + 1, 77)
    n = InStr(get_data, "区")
    If n > 1 And n < 5 Then
        If Right(sp_data, 2) = "市," Then
            sp_data = Left(sp_data, Len(sp_data) - 1)

        End If
        sp_data = sp_data & Mid(get_data, 1, n) & ","
        mid_cnt = mid_cnt + n
    End If

    get_data = Mid(data, mid_cnt + 1, 69)
    If Not sp_data Like "*市*" And Not sp_data Like "*区*" Then
        n = InStr(get_data, "郡")
        If n > 1 Then
            sp_data = sp_data & Mid(get_data, 1, n) & ","
            mid_cnt = mid_cnt + n
        End If
    End If
    get_data = Mid(data, mid_cnt + 1, 77)
    sp_data = sp_data & Mid(get_data, 1, 77) & ","
    yata = Split(sp_data, ",")(0)
    sp_data = Right(sp_data, Len(sp_data) - Len(yata) - 1)

 End Function

 Sub macro()
        Dim c

        For Each c In Range(st_adrs).Resize(end_adrs)
            If IsError(c) Then
                Range(c.Address).Select

                err_adrs = Split(ActiveCell.Formula, "(")(1)

                err_adrs = Left(err_adrs, Len(err_adrs) - 1)
                c.Formula = "=yata(" & err_adrs & ":" & adrs_data(1) & ")"
            End If
        Next c
 End Sub

 'そのシートのシートモジュールへ
 '-----------------------
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim msg As Range
    Dim i As Integer, t As Integer, m As Integer, f As Integer, n As Integer
    Dim rng As String, trgt_data As String
    Dim data_a
    Static j As Integer

    If Target.Count > 1 Then Exit Sub
    On Error GoTo trbl
      data_a = Target.Formula
    If data_a Like "*:*" Then
        j = 0
        Target.Formula = "=yata(" & adrs1 & ")"
        Exit Sub
    End If
    Set msg = Intersect(Target, tbl)
    If msg Is Nothing And Left(data_a, 6) <> "=yata(" Then Exit Sub
    trgt_data = sp_data
    If Not msg Is Nothing Then
        For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
            If Range(c.Address).Formula = "=yata(" & Target.Address(0, 0) & ")" Then
                Range(c.Address).Formula = Range(c.Address).Formula
                If Target = "" Then Range(c.Address).Offset(, 1).Resize(, 3).ClearContents
                    Exit Sub
            End If
        Next c
    End If

    If Left(data_a, 6) = "=yata(" Then
        Application.EnableEvents = False
        Target.Offset(, 1).Resize(, 3).ClearContents
        t = InStr(data_a, "(")
        m = InStr(data_a, ")")
        rng = Mid(data_a, t + 1, m - t - 1)
        msoft = Split(trgt_data, ",", -1)
        For i = 0 To UBound(msoft) - 1
            f = Application.WorksheetFunction.Find(msoft(i), Range(rng), 1)
            n = Len(msoft(i))
            If msoft(i) <> "" Then
                Target.Offset(, i + 1).Formula = "=mid(" & rng & "," & f & "," & n & ")"
            End If
        Next i
    End If
    If flag Then
        For j = j + 1 To end_adrs - 1
            Range(st_adrs).Offset(j).Formula = "=yata(" & Range(adrs).Cells(j + 1, 1).Address(0, 0) & ")"
        Next j

    End If
    flag = False
    If maxrng > 180 And cnt = 0 Then
        MsgBox "続けてmacroを実行して下さい"
        maxrng = 0
        cnt = 1
    End If
trbl:
    Application.EnableEvents = True

 End Sub


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.