Sub MyNameSpacing() Rem *----*----* *----*----* *----*----* *----*----* Rem 単一セル内 姓名 分かち書き処理 Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem 1. 姓名を入力した項目のある列で、分かち書きを実行する。 Rem 注記... Rem 1. 処理前に、指定した列の最終行のセルを取得する。 Rem Excel 97-2003の最大行は、6万5536行(最大列256) Rem Excel 2007-の最大行は、104万8576行(最大列1万6384) Rem データ量が最大行より少ない場合に、この処理は有効。 Rem 2. 分かち書きしたい列のデータの先頭を選択してから、 Rem この処理を実行すること。 Rem 3. 必ずしも、正しい結果にはならない。 Rem ([ふりがな]機能の単語の扱いによる。) Rem 分かち書き訂正処理(MyNameSpacingOhNo)での対処が必要。 Rem 履歴... Rem 第01版:2007/08/09:作成。 Rem *----*----* *----*----* *----*----* *----*----* Dim Cc As Long Dim Rr As Long Dim RrMin As Long Dim RrMax As Long Dim myLen As Long Rem *----*----* *----*----* *----*----* *----*----* ' Rem 指定した列の最終行のセルを取得する。 Cc = ActiveCell.Column RrMin = ActiveCell.Row ' ActiveCell.SpecialCells(xlLastCell).Select ' 使われたセル範囲内の最後のセルを選択。 ActiveCell.Offset(1, 0).Select ' 途中の空白行を取得しないようにするため、わざと1行下に移動。 Cells(ActiveCell.Row, Cc).Select ' 最終行を取得したい列に移動する。 Selection.End(xlUp).Select ' 最終行に移動する。 RrMax = ActiveCell.Row Rem *----*----* *----*----* *----*----* *----*----* ' Rem 指定列の分かち書き実行。 For Rr = RrMin To RrMax Cells(Rr, Cc).Select ActiveCell.SetPhonetic ' Selection.Phonetics.Visible = True ' If ActiveCell.Phonetics.Count > 1 Then myLen = ActiveCell.Phonetics.Item(1).Length ' 姓の文字数を取得。 Rem 姓の後に半角空白1文字を追加。 ActiveCell.Characters(1, myLen).Text = ActiveCell.Characters(1, myLen).Text & " " End If ' ' Selection.Phonetics.Visible = False ' Call MyNameSpacingOhNo Next ' Rr ' Cells(RrMin, Cc).Select ' 開始セルを選択。 Columns(Cc).EntireColumn.AutoFit ' 指定列の幅を調整。 End Sub ' MyNameSpacing *----*----* *----*----* *----*----* *----*----* Sub MyNameSpacingOhNo(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem 分かち書き訂正処理 Rem *----*----* *----*----* *----*----* *----*----* Select Case ActiveCell.Value Case "東国 原英夫" ActiveCell.Value = "東国原 英夫" End Select End Sub ' MyNameSpacingOhNo *----*----* *----*----* *----*----* *----*----*