今回は、宛名印刷に入稿される住所データについてのお話です。
なにかの参考になればとと思い紹介します。

［目次］
宛名住所データの問題　企業名編
宛名住所データ正規化スクリプト
宛名住所データスクリプトコード

宛名住所データの問題　企業名編

宛名印刷の依頼時に入稿していただく住所データの中には、［企業名・団体名等］の社名欄に、その部署までが記入されている場合が結構あるんです。
お客様には、会社名と事業所・支店・・・・・とは分けてくださいとお願いしてます。

次の例を見ていただければ、セルを分けておいた方が良い事が理解していただけると思います。

宛名レイアウトプログラムでは、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