宛名用住所データ 会社・部署分離
管理者用
今回は、宛名印刷に入稿される住所データについてのお話です。
なにかの参考になればとと思い紹介します。
［目次］
宛名住所データの問題 企業名編
宛名住所データ正規化スクリプト
宛名住所データスクリプトコード
宛名印刷の依頼時に入稿していただく住所データの中には、［企業名・団体名等］の社名欄に、その部署までが記入されている場合が結構あるんです。
お客様には、会社名と事業所・支店・・・・・とは分けてくださいとお願いしてます。
次の例を見ていただければ、セルを分けておいた方が良い事が理解していただけると思います。
宛名レイアウトプログラムでは、1セル、1行の組版を行ってます。
［会社名 部署名］ では、文字数が多くなり、1行に収まらない事が出て来ます。
フォントサイズを小さくしなければなりません。
［会社］ ［部署名］ と分けて頂いた方がバランスも良い、レイアウトが可能となります。
宛名住所データ正規化スクリプト
先に紹介した問題を解消するため、お客様に、無理を言って、訂正していただくこともあるのですが、既に持っている住所リストを作り直すのは大変なようです。
このような事もあって、了解いただければ、弊社側で手直しする場合があります。
件数が少なければ、カット＆ペーストで対応出来ますが、多い場合は、大変な作業となります。
したがいまして、以前に作っておいた企業名と部署名等を分けるスクリプトを紹介します。大分前に、作っておいたものですが、結構重宝してます。
［元データ］
［分離した結果］
ちょっと、判断が出来ない・不安な場合は、●●●を付けてます。
スクリプトは、最後に着けてますので、コピー、訂正して使用してください。
宛名住所データ正規化スクリプト コード
Ｅｘｃｅｌ ＶＢＡ として記述してます。コピーして使用できますが、
使用して発生する問題につきましては、責任負いかねます事をご了解ください。
Rem 会社名と営業所等を分離する
Rem シート１のデータを調査 結果はシート２
Rem 2013-06-20
Private Sub CommandButton1_Click()
Dim cuntAA, cuntC, cuntB, 番号, 会社名, 会社名_A, 会社名_B, sp, Er, kb, ErCek
Rem シート１の１列目には連番で番号がふってあるものとします。
Rem 最終行のデータ（数値）を見て 行数を調べます。
Sheets("sheet1").Select
Range("A1").Select
Selection.End(xlDown).Select
cuntAA = ActiveCell
cuntC = 2
Sheet2.Cells(1, 1) = "番号"
Sheet2.Cells(1, 2) = "会社名"
Sheet2.Cells(1, 3) = "セクション1"
Er = ""
For cuntB = 1 To cuntAA Step 1
Er = ""
番号 = Sheet1.Cells(cuntC, 1)
Rem データの正規化を行います
会社名 = Sheet1.Cells(cuntC, 2)
会社名 = henkan.sp1_1(会社名)
会社名 = henkan.sp_cut(会社名)
会社名 = henkan.katakana(会社名)
会社名 = henkan.kabu(会社名)
kb = InStr(1, 会社名, "株式会社", 1) '株式会社検索
If kb >= 2 Then
'●●株式会社
会社名_A = Mid(会社名, 1, kb + 3)
会社名_B = Mid(会社名, kb + 5)
Else
If kb = 1 Then
'株式会社●●
sp = InStr(6, 会社名, " ", 1) 'supe株式会社検索
If Not sp = 0 Then
会社名_A = Mid(会社名, 1, sp)
会社名_B = Mid(会社名, sp)
会社名_B = sp1_1(会社名_B)
ErCek = Left(会社名_B, 1)
If (ErCek >= "Ａ" And ErCek <= "Ｚ") Or (ErCek >= "ア" And ErCek <= "ン") Then
Er = "●●●"
End If
Else
会社名_A = 会社名
会社名_B = ""
End If
Else
会社名_A = 会社名
会社名_B = ""
End If
End If
Sheet2.Cells(cuntC, 1) = 番号
If Er = "●●●" Then
Sheet2.Cells(cuntC, 2) = Er & 会社名_A
Sheet2.Cells(cuntC, 3) = Er & 会社名_B
Else
Sheet2.Cells(cuntC, 2) = 会社名_A
Sheet2.Cells(cuntC, 3) = 会社名_B
End If
cuntC = cuntC + 1
Next cuntB
End Sub
Function sp1_1(moji)
'スペースを１つにする
If Not IsNull(moji) Or Not moji = "" Then
moji = LTrim(moji) '両端スペース削除
moji = RTrim(moji)
moji = Replace(moji, " ", " ")
moji = Replace(moji, " ", " ")
moji = Replace(moji, " ", " ")
moji = Replace(moji, " ", " ")
moji = Replace(moji, " ", " ")
cvat_A = moji
Else
cvat_A = ""
End If
sp1_1 = cvat_A
End Function
Function sp_cut(moji)
CRコード = Chr(13)
LFコード = Chr(10)
TBコード = Chr(9)
moji = Replace(moji, CRコード, " ")
moji = Replace(moji, LFコード, " ")
moji = Replace(moji, TBコード, " ")
moji = LTrim(moji) '両端スペース削除
moji = RTrim(moji)
sp_cut = moji
AB = 0
If Not moji = "" Then
AB = Len(moji)
If AB = 1 Then
mojiA = Replace(moji, " ", " ")
If mojiA = " " Then
sp_cut = ""
End If
End If
End If
End Function
Function katakana(moji)
If Not moji = "" Then
moji = LTrim(moji) '両端スペース削除
moji = RTrim(moji)
moji = henkan.mainasu(moji)
cvat_A = StrConv(moji, vbWide)
Else
cvat_A = ""
End If
katakana = cvat_A
End Function
Function kabu(moji)
moji = Replace(moji, "㈱", "株式会社 ")
moji = Replace(moji, "（株）", "株式会社 ")
moji = Replace(moji, "(株)", "株式会社 ")
moji = Replace(moji, "（有）", "有限会社 ")
moji = Replace(moji, "(有)", "有限会社 ")
moji = Replace(moji, "㈲", "有限会社 ")
moji = Replace(moji, " ", " ")
kabu = moji
End Function
Function mainasu(moji)
moji = Replace(moji, "ー", "ー")
moji = Replace(moji, "‐", "ー")
moji = Replace(moji, "-", "ー")
moji = Replace(moji, "―", "ー")
moji = Replace(moji, "-", "ー")
moji = Replace(moji, "－", "ー")
mainasu = moji
End Function
