[[20130508093414]]　『五十音順の住所録への登録』（もす）　ページの最後に飛ぶ

『五十音順の住所録への登録』（もす）

 職場のPCにAccessが無いのでExcelで顧客名簿を登録するユーザーフォームを作っています。

 まず、「住所録」シートのレイアウトは下記のような感じです。

 　　　A　　　　　B　　　　　　　　　C　　　　　　　　　　D　　　　　　　E　　　　　　　　　　　F　　　　　　　G　　　　　　　H
 1
 2　見出し　　　社名　　　　　　　　ﾌﾘｶﾞﾅ　　　　　　　郵便番号　　　　　住所　　　　　　　　　　TEL　　　　　　FAX　　　　　備考
 3　ア行　　青木企画(株)　　　　　　ｱｵｷｷｶｸ　　　　　 　162-0806　東京都新宿区榎町○○　　　　03-XXXX-XXXX　03-ZZZZ-ZZZZ　　　
 4　　　　　(株)朝日商事福岡支店　　ｱｻﾋｼｮｳｼﾞﾌｸｵｶｼﾃﾝ　　810-0001　福岡県福岡市中央区天神△△　092-XXX-XXXX　092-ZZZ-ZZZZ　　　発注先
 5　　　　　(株)朝日商事本社　　　　ｱｻﾋｼｮｳｼﾞﾎﾝｼｬ　　　 135-0064　東京都江東区青海××　　　　03-XXXX-ZZZZ　03-ZZZZ-XXXX　　　
 ～～～～～～
 20 カ行　　(株)片岡商店　　　　　　ｶﾀｵｶｼｮｳﾃﾝ　　　　　812-0888　福岡県福岡市博多区板付□□　092-AAA-AAAA　092-AAA-BBBB　　　倉庫
 21　　　　 (株)片岡商店　　　　　　ｶﾀｵｶｼｮｳﾃﾝ　　　　　830-0018　福岡県久留米市通町●●　　　0942-BB-BBBB　0942-CC-CCCC
 22　　　　 関西工業(有)　　　　　　ｶﾝｻｲｺｳｷﾞｮｳ　　　　 541-0053　大阪府大阪市中央区本町▲▲　06-DDDD-DDDD　06-DDDD-DDDD

 C列の「ﾌﾘｶﾞﾅ」は並べ替えのためのもので、「(株)」などの法人種別は含まず、通常はC列は非表示になっています。

 ユーザーフォームでは、TextKigyo　というテキストボックスに社名を入れると、TextKana　というテキストボックスに
 ﾌﾘｶﾞﾅが半角ｶﾀｶﾅで表示されるようにしています

 Private Sub TextKigyo_Exit(ByVal Cancel As MSForms.ReturnBoolean)

 Dim Shamei As String
 Dim Kana As String

    Shamei = TextKigyo.Text
    Kana = Application.GetPhonetic(Shamei)

    TextKana.Text = StrConv(Kana, vbNarrow)

 End Sub

 さらに郵便番号を入力したら、郵便番号マスターシートを参照して該当住所が「住所」のテキストボックスに
 表示されるようにしています。

 この住所録は全体に格子罫線が設定されていて、「ア行」と「カ行」など五十音の区切りと
 全体の枠線を太線の罫線が引いてあります。

 全体の並び順はﾌﾘｶﾞﾅの昇順で、たまに上の「片岡商店」のように同じ社名が入ることがあります。
 （その時の並びは特に決まっていません。「○○支店」などが入ればそれもﾌﾘｶﾞﾅに含めてその順序になります）

 それで、質問が２つあります。

 １：この住所録にデータを登録する場合ですが、例えば上記のデータに
 「川野建設(株)」（ｶﾜﾉｹﾝｾﾂ）
 というデータを登録するとします。

 その時、読み仮名の順番通りに21行目の「片岡商店」と22行目の「関西工業(有)」の間に
 行を挿入して（できれば罫線などの書式設定も引き継いで）データを登録したいのですが、
 ユーザーフォームの TextKana　の読みを参照して直接21行目と22行目の間にデータを挿入するにはどうしたらいいかと思いまして…

 新規データを最下行に入れて並び替え…では罫線などが崩れてしまうことがありますし…

 ２：やはり新規登録で、上記データに「相川製作所」（ｱｲｶﾜｾｲｻｸｼｮ）というデータを登録するとします。

 するとア行の一番上の「青木企画」よりも上になります（ア行の先頭行にデータが登録される）

 A列にはそれぞれの五十音の見出しが先頭行に入力されていますので、もし（１）の質問がうまくいって
 新規データが先頭行に登録された場合

  　　　A　　　　　B　　　　　　　　　C　　　　　（略）
 1
 2　見出し　　　社名　　　　　　　　ﾌﾘｶﾞﾅ　　
 3　ア行　　相川製作所(株)　　　　　ｱｲｶﾜｾｲｻｸｼｮ　　　
 3　　　　　青木企画(株)　　　　　　ｱｵｷｷｶｸ

 のように「ア行」という見出しが先頭行に表示されるようにしたいのですが、どのように判別すればよいでしょうか。

 エクセルのバージョンは2010です。

 分かりにくいと思いますので不足部分は補います。

 よろしくお願いいたします。

 罫線の状況なんかがみえないところもあるけど、たたき台として。
 CommandButton1 が押されたら転記ということにしてある。
 〇行　のセットは　getChar　を使っているけど、そこのコードは手抜き。
 実際には濁音からはじまる名前もあるので、そのあたりは、コードの大小を調べて
 ここに網羅しておいてね。
 また、項目の書き込みは C列だけのコード。実際には、ここに必要な項目転記コードを追加。

 Private Sub CommandButton1_Click()
    Dim z As Long
    Dim x As Variant
    Dim c As Range
    Dim s As String
    Dim o As String

    With Sheets("住所録")
        z = .Range("B" & .Rows.Count).End(xlUp).Row
        x = Application.Match(TextKana.Text, .Range("C2:C" & z), 1)
        If IsError(x) Then
            x = 2
        Else
            x = x + 2
        End If
        .Rows(x).Insert
        If x > z Then
            .Rows(z).Copy
            .Cells(x, "A").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                                    SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End If

        'ここで　x 行目に対して項目セット
        .Cells(x, "C").Value = TextKana.Text

        .Range("A2:A" & z + 1).ClearContents

        For Each c In .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
            If c.Row = 2 Or Left(c.Value, 1) <> Left(c.Offset(-1).Value, 1) Then s = getChar(Left(c.Value, 1))
            If s <> o Then c.Offset(, -2).Value = s & "行"
            o = s
        Next

    End With
 End Sub

 Private Function getChar(s As String) As String
    Select Case s
        Case Is >= "ﾜ": getChar = "ﾜ"
        Case Is >= "ﾗ": getChar = "ﾗ"
        Case Is >= "ﾔ": getChar = "ﾔ"
        Case Is >= "ﾏ": getChar = "ﾏ"
        Case Is >= "ﾊ": getChar = "ﾊ"
        Case Is >= "ﾅ": getChar = "ﾅ"
        Case Is >= "ﾀ": getChar = "ﾀ"
        Case Is >= "ｻ": getChar = "ｻ"
        Case Is >= "ｶ": getChar = "ｶ"
        Case Is >= "ｱ": getChar = "ｱ"
    End Select
 End Function

 (ぶらっと)

 ぶらっと様、ありがとうございます。だいたいできました。

 すみません、罫線の説明ができていませんでした。

 表のレイアウトは下記のようになっています

 ┏━━━┯━━━━━━━━━━━━┯━━━━━━━━┯━━━━━━━━━
 ┃見出し│　　　　社名　　　　　　│　　ﾌﾘｶﾞﾅ　　 　│　　郵便番号
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━
 ┃ア行　│青木企画(株)　　　　　　│ｱｵｷｷｶｸ　　　　　│162-0806
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)朝日商事福岡支店　　│ｱｻﾋｼｮｳｼﾞﾌｸｵｶｼﾃﾝ │810-0001
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)朝日商事本社　　　　│ｱｻﾋｼｮｳｼﾞ本社　  │135-0064
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━
 ┃カ行　│(株)片岡商店　　　　　　│ｶﾀｵｶｼｮｳﾃﾝ 　　　│812-0888
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)片岡商店　　　　　　│ｶﾀｵｶｼｮｳﾃﾝ 　　　│830-0018

 それで、「ア行」など五十音の先頭に新規データが入った場合

 ┏━━━┯━━━━━━━━━━━━┯━━━━━━━━┯━━━━━━━━━
 ┃見出し│　　　　社名　　　　　　│　　ﾌﾘｶﾞﾅ　　 　│　　郵便番号
 ┃　　　├────────────┼────────┼─────────
 ┃ア行　│相川製作所(株)　　　　　│ｱｲｶﾜｾｲｻｸｼｮ　　　│729-0111
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━
 ┃　　　│青木企画(株)　　　　　　│ｱｵｷｷｶｸ　　　　　│162-0806
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)朝日商事福岡支店　　│ｱｻﾋｼｮｳｼﾞﾌｸｵｶｼﾃﾝ │810-0001
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)朝日商事本社　　　　│ｱｻﾋｼｮｳｼﾞ本社　  │135-0064
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━
 ┃カ行　│(株)片岡商店　　　　　　│ｶﾀｵｶｼｮｳﾃﾝ 　　　│812-0888
 ┃　　　├────────────┼────────┼─────────
 ┃　　　│(株)片岡商店　　　　　　│ｶﾀｵｶｼｮｳﾃﾝ 　　　│830-0018

 このように、「ア行」のような「見出し」が区切りの罫線の上にはみ出してしまいました…

 やはりこういう罫線まで全部思い通りにしてデータを挿入するのは難しいでしょうか…

 （もす）

 なるほど。

 でも、この形なら、先頭に追加された時には

 ┏━━━┯━━━━━━━━━━━━┯━━━━━━━━┯━━━━━━━━━
 ┃見出し│　　　　社名　　　　　　│　　ﾌﾘｶﾞﾅ　　 　│　　郵便番号
 ┃　　　├────────────┼────────┼─────────
 ┃ア行　│相川製作所(株)　　　　　│ｱｲｶﾜｾｲｻｸｼｮ　　　│729-0111
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━

 ではなく

 ┏━━━┯━━━━━━━━━━━━┯━━━━━━━━┯━━━━━━━━━
 ┃見出し│　　　　社名　　　　　　│　　ﾌﾘｶﾞﾅ　　 　│　　郵便番号
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━
 ┃ア行　│相川製作所(株)　　　　　│ｱｲｶﾜｾｲｻｸｼｮ　　　│729-0111
 ┣━━━┿━━━━━━━━━━━━┿━━━━━━━━┿━━━━━━━━━

 こんなふうになっていない？

 いずれにしても、この形であれば、いったんすべての罫線を削除して、できあがったリストに対して
 罫線を再設定したほうが、やりやすいかもしれない。

 ということで、とりあえず、書いてみたけど・・・
 罫線の種類は、適当に設定しているので、実際に合わせてチューニングしてほしい。

 CommandButton1_Click のみ以下と入れ替え。

 Private Sub CommandButton1_Click()
    Dim z As Long
    Dim x As Variant
    Dim c As Range
    Dim s As String
    Dim o As String
    Dim r As Range

    Application.ScreenUpdating = False

    With Sheets("住所録")
        .Cells.Borders.LineStyle = xlNone
        z = .Range("B" & .Rows.Count).End(xlUp).Row
        x = Application.Match(TextKana.Text, .Range("C2:C" & z), 1)
        If IsError(x) Then
            x = 2
        Else
            x = x + 2
        End If
        .Rows(x).Insert

        'ここで　x 行目に対して項目セット
        .Cells(x, "C").Value = TextKana.Text

        Set r = .Range("C1", .Range("C" & .Rows.Count).End(xlUp)).EntireRow.Columns("A:H")
        r.Borders.LineStyle = xlNone    'いったん罫線削除

        'B列～H列
        With r.Columns("B:H").Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        '大外枠
        r.BorderAround xlContinuous, xlMedium
        .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).ClearContents

        For Each c In .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
            If c.Row = 2 Or Left(c.Value, 1) <> Left(c.Offset(-1).Value, 1) Then s = getChar(Left(c.Value, 1))
            If s <> o Then
                c.Offset(, -2).Value = s & "行"
                With c.EntireRow.Columns("A:H").Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            End If
            o = s
        Next

    End With

    Application.ScreenUpdating = True

 End Sub

 (ぶらっと)

 (ぶらっと)

 ありがとうございます。

 またも私の書き方が悪くて罫線が1行目（罫線なし）に引かれてしまったので、罫線がセットされた後で1行目に
 引かれた罫線を消すコードを付け加えてみたらうまくいきました。

 丁寧に教えてくださってありがとうございました

 （もす）

コメント返信：

[ 一覧(最新更新順) ]

[[20130508093414]] 『五十音順の住所録への登録』（もす） ページの最後に飛ぶ

[[20130508093414]]　『五十音順の住所録への登録』（もす）　ページの最後に飛ぶ