[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『住所の分割について』（裕）
１つのセルに都道府県〜の住所があり分割したいのですができますでしょうか？
Ａセル
神奈川県横浜市神奈川区反町１−１−１０
これを
Ａセル
神奈川県
Ｂ
横浜市神奈川区（または、２３区、〜市、〜郡）
Ｃ
それ以降
のような形にしたいのです
こちらをご参考に。（ぷーのすけ） ↓ [[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.