Excelで名前の7文字組みの方法を教えてください

Excelデータで名前をスペースで入れて7文字組みに変換させたいのですが、
関数またはVBAなどの方法を教えていただけませんでしょうか？
今は関数で個別でMID関数を使い分けてしています。

例）　
林一　　　　→　林　　　　　一　　　　　田中一　　　→　田　中　　　一
林太郎　　　→　林　　　太　郎　　　　　田中太郎　　→　田　中　太　郎
林孝太郎　　→　林　　　孝太郎　　　　　田中孝太郎　→　田　中　孝太郎

佐々木一　　→　佐々木　　　一
佐々木太郎　→　佐々木　太　郎
佐々木孝太郎→　佐々木　孝太郎

No.4 ベストアンサー 回答者： CoalTar 回答日時： 2017/06/13 17:06

板汚しすみません。

まだ半角スペース残ってた
=CHOOSE(LEN(A2),,LEFT(A2,1)&REPT("　",5)&RIGHT(A2,1),
REPLACE(LEFT(A2,B2),2,0,REPT("　",B2-1))&REPT("　",3)&REPLACE(RIGHT(A2,3-B2),2,0,REPT("　",2-B2)),
IF(MOD(B2,2),LEFT(A2,B2)&REPT("　",3)&RIGHT(A2,4-B2),
REPLACE(LEFT(A2,2),2,0,"　")&"　"&REPLACE(RIGHT(A2,2),2,0,"　")),
IF(OR(B2=1,B2=4),LEFT(A2,B2)&REPT("　",2)&RIGHT(A2,5-B2),
REPLACE(LEFT(A2,B2),2,0,REPT("　",3-B2))&"　"&REPLACE(RIGHT(A2,5-B2),2,0,REPT("　",B2-2))),
LEFT(A2,B2)&"　"&RIGHT(A2,6-B2),A2)

この回答へのお礼

出来れば関数の内容などを教えていただけると助かります^^

お礼日時：2017/06/14 15:25

No.5 回答者： WindFaller 回答日時： 2017/06/14 09:11

こんにちは。

とても気になった質問なので、私も本格的に試してみました。
なかなか手間の掛かる準備が必要です。

VBA系とは違う種類のプログラムですが、あえて、それをVBAでやってみました。
当然、VBAだけでは、不可能ですし、当然、関数だけでも不可能です。形態素解析のツールのkakasi を使って分かち書きをするわけですが、ただ、本来は人名辞典が必要です。MS-IMEの辞書は、今は抜き取れないのでしょうか？昔のWXの時代なら、取り出せたのですが。

Vector には以下のような人名辞書があります。WXIII用のものもあるようです。これは、テキストファイルですから、容易に抜き出せます。
http://www.vector.co.jp/vpack/filearea/data/writ …

今回は、私にとっても初めての組み込みで、デフォルトの辞書のままでやってみました。
「田中一」なら、反応するのに、「田中角栄」には反応しないという矛盾とも思える現象があります。

まず、Kakasi というプログラムを手に入れてください。

kakasi-2.3.4.zip
http://www.namazu.org/win32/

１）Windowsへの「kakasi」の導入方法
http://language-and-engineering.hatenablog.jp/en …

ここらを参考にしてみてください。Path をコンパネのシステムから加えるのもお忘れなく。
辞書は、mkkanwa.exe　を使って作ります。
まだ、細かい所はチェックしていませんが、仕組みは分かっていただけるはずです。

'//
Sub KakasiForVBA()
　Dim ret As Variant
　Dim myName As String
　Dim c As Variant, k As Long, k2 As Long
　Dim fmt1 As String, fmt2 As String
　Dim faName As String, fiName As String
　With Range("B2", Cells(Rows.Count, 2).End(xlUp))
　　.ClearContents
　　.Font.Name = "MS ゴシック"
　End With
　
　For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
　Application.ScreenUpdating = False　'ループが終わったら見えるようにする
　　Do
　　　myName = Replace(c, Space(1), "", , , vbTextCompare)
　　Loop Until InStr(1, myName, Space(1), vbTextCompare) = 0
　　If c.Value Like "[一-龠]*" Then
　　　ret = DivideName(CStr(c.Value))
　　　ret = Application.Clean(ret)
　　　ret = Trim(ret)
　　　If ret <> "0" Then
　　　　k = InStr(ret, Space(1))
　　　　k2 = InStr(k + 1, ret, Space(1))
　　　　If k > 0 Then
　　　　　'family name
　　　　　If k2 = 4 Then
　　　　　faName = Trim(Mid(ret, 1, k2 - 1))
　　　　　Else
　　　　　faName = Trim(Mid(ret, 1, k - 1))
　　　　　End If
　　　　　faName = Replace(faName, Space(1), "")
　　　　　Select Case Len(faName)
　　　　　Case 1: fmt1 = "@" & Space(3)
　　　　　Case 2: fmt1 = "@ @"
　　　　　Case 3: fmt1 = "@@@"
　　　　　Case 4: fmt1 = "@@@@"
　　　　　End Select
　　　　　faName = Format$(faName, fmt1)
　　　　　'first name
　　　　　If k2 = 4 Then
　　　　　fiName = Trim(Mid(ret, k2 + 1))
　　　　　Else
　　　　　fiName = Trim(Mid(ret, k + 1))
　　　　　End If
　　　　　fiName = Replace(fiName, Space(1), "")
　　　　　Select Case Len(fiName)
　　　　　Case 1: fmt2 = Space(4) & "@"
　　　　　Case 2: fmt2 = Space(1) & "@" & Space(1) & "@"
　　　　　Case 3: fmt2 = "@@@"
　　　　　Case 4: fmt2 = "@@@@"
　　　　　End Select
　　　　　fiName = Format$(fiName, fmt2)
　　　　　c.Offset(, 1).Value = Space(1) & faName & Space(1) & fiName
　　　　　faName = "": fiName = ""
　　　　 End If
　　　　End If
　　　End If
　　　Application.ScreenUpdating = True
　　Next
　End Sub
　
　Function DivideName(ByVal myName As String)
　Dim WShell As Object
　Dim oExec As Object
　Dim sResult As String
　Dim sCommand As String
　Dim execmd As String
　Dim nowDir As String
　nowDir = ThisWorkbook.Path　'CurDir()
　Set WShell = CreateObject("WScript.Shell")

　ChDir "c:\kakasi"
　execmd = " c:\kakasi\bin\kakasi.exe -w"
　sCommand = "cmd /c echo " & myName & " |" & execmd　'kakasi -w"
　Set oExec = WShell.Exec(sCommand)

　Do Until oExec.Status: DoEvents: Loop

　If Not oExec.StdErr.AtEndOfStream Then
　　sResult = oExec.StdErr.ReadAll
　ElseIf Not oExec.StdOut.AtEndOfStream Then
　　sResult = oExec.StdOut.ReadAll
　End If
　If sResult <> "" Then
　　''Debug.Print sResult
　　DivideName = sResult
　Else
　　DivideName = "0"
　End If
　ChDir nowDir
End Function
'//

注：このkakasiは、姓と名の分かち書きを任せているにすぎず、細かな調整をしているわけではありません。

No.3 回答者： CoalTar 回答日時： 2017/06/13 16:51

一部半角スペースになっていたのを修正

=CHOOSE(LEN(A2),,LEFT(A2,1)&REPT("　",5)&RIGHT(A2,1),
REPLACE(LEFT(A2,B2),2,0,REPT(" ",B2-1))&REPT("　",3)&REPLACE(RIGHT(A2,3-B2),2,0,REPT("　",2-B2)),
IF(MOD(B2,2),LEFT(A2,B2)&REPT("　",3)&RIGHT(A2,4-B2),
REPLACE(LEFT(A2,2),2,0," ")&"　"&REPLACE(RIGHT(A2,2),2,0," ")),
IF(OR(B2=1,B2=4),LEFT(A2,B2)&REPT("　",2)&RIGHT(A2,5-B2),
REPLACE(LEFT(A2,B2),2,0,REPT("　",3-B2))&"　"&REPLACE(RIGHT(A2,5-B2),2,0,REPT("　",B2-2))),
LEFT(A2,B2)&"　"&RIGHT(A2,6-B2),A2)

No.2 回答者： CoalTar 回答日時： 2017/06/13 16:47

長いです。

文字数で分岐、B列名字の文字数(2文字と7文字の場合はいらないけど)
=CHOOSE(LEN(A2),,LEFT(A2,1)&REPT("　",5)&RIGHT(A2,1),
REPLACE(LEFT(A2,B2),2,0,REPT(" ",B2-1))&REPT("　",3)&REPLACE(RIGHT(A2,3-B2),2,0,REPT(" ",2-B2)),
IF(MOD(B2,2),LEFT(A2,B2)&REPT("　",3)&RIGHT(A2,4-B2),
REPLACE(LEFT(A2,2),2,0," ")&"　"&REPLACE(RIGHT(A2,2),2,0," ")),
IF(OR(B2=1,B2=4),LEFT(A2,B2)&REPT("　",2)&RIGHT(A2,5-B2),
REPLACE(LEFT(A2,B2),2,0,REPT(" ",3-B2))&"　"&REPLACE(RIGHT(A2,5-B2),2,0,REPT(" ",B2-2))),
LEFT(A2,B2)&"　"&RIGHT(A2,6-B2),A2)

No.1 回答者： 銀鱗 回答日時： 2017/06/13 15:16

「金田一太郎」…さて、このかたは「かねだ　いちたろう」さんでしょうか、「きんだいち　たろう」さんでしょうか。

どこで区切るかを細かく指定する非常に大きなデータベースを抱えたプログラムになるので、
現状のやり方で良いと思います。