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 *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system