[VBA]ExcelでUTF-8とUTF-16LEの絵文字💖、異体字辻󠄀、サロゲートペア𠮷の番号を求める

Excelは単純な絵文字以外は入力ができない

ALT+Xでは入力できない

Wordのような機能がない。

色が出ない

色が出るのはWordはやっとできるようになったがExcelはできない。

FontはSegoe UI Emoji

FontはSegoe UI Symbolでもよさそうだが基本的に限定されていた。
ただし現在のWindowsとOfficeのバージョン（2023年2月）ではUDPゴシックなどでも表示された。どうもまた変わっているらしい。

以前WIN32APIとスピルと組み合わせたが

https://qiita.com/Q11Q/items/98d1f5e4e886bec6c240
あまりうまくいかない。

後はUNICODE関数だが。。。

ここでUTF-8の番号なら入力できる。
しかし、複数の番号になればお手上げ。

今回のすごさ

ただしExcel2013以降、Windows10 最新バージョン以降

UNICODE関数はもうちょっと前から対応しているが、システムが対応しないと難しい。
まだ十分ではないが、2023年2月4日以降では動く。

自働計算はONで

出ないとワークシート関数を入れた時点で計算しないので、バグる可能性がある。
自働計算以外の環境では検証していない。

Win32APIなし

なのでコードがすっきり

参照設定なし

なのでコードがすっきり。

WorkSheetFunctionの活用

WorkSheetFunctionでUTF-8が解決できることが多い。
さらに、サロゲートペアも解決できた。
また、パターン分析から、例外を発見できた。
他方、UTF-16LEはVBAが速い。
特にサロゲートペア、zwjはたいした計算も工夫もなく求められてしまう。

Excel2013からできてUnicode関数はUTF-8

実はUnicode関数はUTF-8で値を返す。
そして、VBAはUTF-16LEで返す。
この違いを利用して、コードが単純になった。
それでもかなり長いが。

文字コードの取得

元ネタになる絵文字等を取得しなければならない。
Unicode emoji 15.0 full list
この表の見方はこちら
https://atmarkit.itmedia.co.jp/ait/articles/1604/27/news051.html

それでURLを右クリックしてリンクを取得。
1620番がこちら。
https://unicode.org/emoji/charts/full-emoji-modifiers.html#1f469_1f3fc_200d_2764_fe0f_200d_1f48b_200d_1f468_1f3ff
#以降の
1f469_1f3fc_200d_2764_fe0f_200d_1f48b_200d_1f468_1f3ff
がコードとなる。リンクをメモ帳にコピーし、
_
を
" , "
に置換。
行末に)
そして文頭に
ActiveCell.value=UCS4String("
を加えると出来上がる。後ろに番号と解説を入れる

ActiveCell.Value = UCS4String("1f469", "1f3fb", "200d", "2764", "fe0f", "200d", "1f48b", "200d", "1f468", "1f3ff") ' Full List Number 1615 kiss: woman, man, light skin tone, dark skin tone

このよう注釈を加えて、後からリストを参照しやすいようにする。

USC4Stringの改善点

そのまま導入してもよいが、ここだけ変える。
c = "&H" & Replace(Replace(Replace(LCase(codes(i)), "u+", "", 1, 1, vbTextCompare), "&#x", "", 1, 1, vbTextCompare), ";", "", 1, 1, vbTextCompare)
としてU+や&#x;の表記を排除したほうがいいと思われる。
ほか、\uをつけている場合もあるだろう。

まずA列に入力する

以上のコードを使って文字をセルに挿入する。
A列の適当なセルをクリックする。
VBAで絵文字💖
こちらのUCS4Stringを使って入力する。
なお、絵文字になった場合は、自動的にフォントが変わらないため、変な表示になる場合がある。
そうした場合はフォントが対応していないので、
Segoe UI Emoji
または
Segoe UI Symbol
に変える。現時点ではカラーにはならない。このためExcelでは肌色を変える（正確には紫外線の反応とか言っているけどわざとらしいなあとしか言いようがない）意味はない。逆にスキントーンを変えて区別するのはOfficeではやらない方がよい。

Sub InsertEmoji()
'ActiveCell.Value = UCS4String("1f9d1", "1f3fc", "200d", "1f91d", "200d", "1f9d1", "1f3fb")
'ActiveCell.Value = UCS4String("D83D", "DD96", "D83C", "DFFB")
'ActiveCell.Value = UCS4String("U+1f596", "U+1f3fb") ' Replaceを追加する必要あり
'ActiveCell.Value = UCS4String("1f469", "1f469", "1f466", "1f466")
'ActiveCell.Value = UCS4String("8FBB", "DB40", "DD01")
'ActiveCell.Value = UCS4String("D83D", "DC69", "D83D", "DC69", "D83D", "DC66", "D83D", "DC66")
'ActiveCell.Value = UCS4String("1f3fd", "200d", "2764", "fe0f", "200d", "1f48b", "200d", "1f469", "1f3ff") ' Wndに表示されないものは失敗する場合がある No 1615
'ActiveCell.Value = UCS4String("1f469", "1f3fd", "200d", "2764", "fe0f", "200d", "1f48b", "200d", "1f469", "1f3ff") ' Full List Numer 1620
'ActiveCell.Value = UCS4String("1f469", "1f3fb", "200d", "2764", "fe0f", "200d", "1f48b", "200d", "1f468", "1f3ff") ' Full List Number 1615
'ActiveCell.Value = UCS4String("D83D", "DC69", "D83C", "DFFB", "200D", "2764", "FE0F", "200D", "D83D", "DC8B", "200D", "D83D", "DC68", "D83C", "DFFF")
'ActiveCell.Value = UCS4String("D83D", "DC69", "D83C", "DFFB", "200D", "2764", "FE0F", "200D", "D83D", "DC8B", "200D", "D83D", "DC68", "D83C", "DFFF")
ActiveCell.Value = UCS4String("1f469", "1f3ff", "200d", "2764", "fe0f", "200d", "1f48b", "200d", "1f468", "1f3fc")        ' No 1632
'ActiveCell.Value = UCS4String("D83D", "DC69", "D83D", "DC69", "D83D", "DC66", "D83D", "DC66")
'ActiveCell.Value = ChrW("&H" & Range("G5")) & ChrW("&H" & Range("H5"))
End Sub

表示がおかしいときはExcelの数式バーでチェック

これはバージョンで変わる可能性があります

セル内ではこんな表示であっても数式バーを見ること。

このように数式バーで表示されていれば成功。フォントがないだけ。
どちらも表示がおかしいときは間違っている可能性がある。

これは理由は明確で&H200Dで結合していることを計算とみなしているらしい。
今回はこのzwjといわれる&H200Dの取り扱いが困難だった。

入力ができたら数式を展開

VBAで関数を入れていくが、次のような関係になる。

B列

まずB列にワークシート関数のUNICODEを16進に変換する関数を入れる。
=DEC2HEX( UNICODE(A28))
通常のUTF-8はB列でわかる。

C列調整後十進数

C列は65536を超えていれば65536を引く。
マイナスの時は65536を足す。
=IF(HEX2DEC($B$28)<0,HEX2DEC($B$28)+65536,IF(HEX2DEC($B$28)>65536,HEX2DEC($B$28)-65536, HEX2DEC($B$28)))

D列 C列を16進に 通常のUTF-16LEのコード

=DEC2HEX($C$28)
D列とB列が同じなら、UTF-16LEのコードはD列となる

E列とF列簡易サロゲートペア

E列 =DEC2HEX(INT($C$28/1024)+HEX2DEC("D800"))
F列 =DEC2HEX(MOD($C$28,HEX2DEC(400))+HEX2DEC("DC00"))
このように計算して上位サロゲートと下位サロゲートが出る。
これで十分か、ワークシート関数とVBAの関数でチェックする。

Ｇ列、Ｈ列、Ｉ列、Ｊ列にLen

ここでコードを追加する。ワークシートでこれらの関数も使う。

' WorkSeetで使うVBAのLen LenB Asc AscW Chr ChrW
Function VBALen(str As String)
VBALen = Len(str)
End Function

Function VBALenB(str As String)
VBALenB = LenB(str)
End Function

Function VBAAsc(str As String) As Integer
VBAAsc = Asc(str)
End Function

Function VBAAscW(str As String) As Integer
VBAAscW = AscW(str)
End Function

Function VBAChrW(iLong As Long) As Integer
VBAChrW = ChrW(iLong)
End Function

' VBAで使う16進=>10進変換関数
Function VBAHex2Dec(HexString As String) As Long
If Left(HexString, 2) <> "&H" Then
VBAHex2Dec = Val("&h" & HexString)
Else
VBAHex2Dec = Val(HexString)
End If
End Function

G列 =LEN($A$28)
H列 =@vbalen($A$28) 現在のバージョンでは勝手に@が付きます。
I列 =LENB($A$28)
J列 =@vbalenb($A$28) 現在のバージョンでは勝手に@が付きます。

K列以降UTF-8

このあとコードを紹介する。関数は
=DEC2HEX(UNICODE(MIDB($A$28,1,2)))
=DEC2HEX(UNICODE(MIDB($A$28,3,2)))
という感じで入っていくがzwjの時&H20
となる時があり、この時はなんちゃってになる。

zwjとVBAの仕様によるエラーとその抑止の必要性

=DEC2HEX(UNICODE(MIDB($A$30,11,1))+8173)
またこの場合、次の文字は1文字だけ進む
=DEC2HEX(UNICODE(MIDB($A$30,12,2)))
また、zwjを使った場合、末尾に必ず&H200Dがつく。
しかし、これが入ると、結合文字は崩れるため、強制的に排除する必要がある。
このバグはG列からI列が
奇数奇数奇数の３つ並びの時に発動する。

UTF-8の次がUTF-16LE

UTF-16 Hex String Array(16)
という列があり、その次に
"D83D","DC69","D83C","DFFF","200D","2764","FE0F","200D","D83D","DC8B","200D","D83D","DC68","D83C","DFFC"
実はこれがUTF-16LEで記述したもの。
また、UCS4String関数は実はUTF-16LEの配列でもUTF-8の配列でもどっちでも文字が入力されるらしい。今のところ例外はない。

UTF-16LEは結合文字で影響されない。

実はzwjはUTF-16LEでも&H200Dと同じ値となっている。
なので、UTF-16LEで入力したほうが確実である。
しかしUTF-8の文字コードから変換するにはどうしたらいいか。
その答えが今回の記事である。
それをVBAでWin32APIなしで行う。

パターンで見分ける

K列から始まる式は
ワークシートのG列からJ列でわかる

通常の全角文字とパターン

1 1 2 2
UTF-8はB列
UTF-16LEはD列
サロゲートペアではない。
サロゲートペアであれば65536を超えるなどするため
B列とD列が一致しない。
細 細はB列とD列が一致しているのでUTF-8とUTF-16LEは一致する。
VBAでは
chrw(val(&H7d30))
のように記述する。

サロゲートペアのパターン

2 2 2 4

文字コードの出現位置

原則

UTF-8がB列
UTF-16LEがE列とF列
サロゲートペアは65536を引くのでB列とD列が一致しない。
このため、列が変わる。

例外

後からIVS、emojiが来るが、単純な記号、emojiはこのパターンの場合もある。
以下はサロゲートペアのE列とF列ではない場合となる。

IVS

3 3 4 6

文字コードの出現位置

UTF-8 K列とL列
UTF-16LE N列
以降、emojiも同じ出現位置となる。

emoji

🧑🏽 #288 person: medium skin tone

4 4 4 8

emoji + zwjは奇数が出るときと偶数が出るときがある

15 15 15 30

このパターンが厄介だが、3つ奇数が出る。
IVSは3で奇数は2つしかない

数式を入力するコード

Sub InsertFormula()
' A列に1文字入れてその位置にフォーカスしてこのSubプロシージャを実行

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim r As Range, iCol As Long, iRow As Long, bbArray() As Byte, bb As Byte
Dim i As Long
Dim buf As String, rst As String
Dim bl As Boolean
Set r = Range(ActiveCell.Address)
r.Offset(, 1).Formula = "=DEC2HEX( UNICODE(A" & r.Row & "))"
r.Offset(, 2).Formula = "=IF(HEX2DEC(" & r.Offset(, 1).Address & ")<0,HEX2DEC(" & r.Offset(, 1).Address & ")+65536,IF(HEX2DEC(" & r.Offset(, 1).Address & ")>65536,HEX2DEC(" & r.Offset(, 1).Address & ")-65536, HEX2DEC(" & r.Offset(, 1).Address & ")))"
r.Offset(, 3).Formula = "=DEC2HEX(" & r.Offset(, 2).Address & ")"
r.Offset(, 4).Formula = "=DEC2HEX(INT(" & r.Offset(, 2).Address & "/1024)+HEX2DEC(""D800""))"
r.Offset(, 5).Formula = "=DEC2HEX(MOD(" & r.Offset(, 2).Address & ",HEX2DEC(400))+HEX2DEC(""DC00""))"
r.Offset(, 6).Formula = "=Len(" & r.Address & ")"
r.Offset(, 7).Formula = "=VBALen(" & r.Address & ")"
r.Offset(, 8).Formula = "=LenB(" & r.Address & ")"
r.Offset(, 9).Formula = "=VBALenB(" & r.Address & ")"
If r.Offset(, 6).Value > 2 Then
iCol = 11
iRow = r.Row
If ws.Cells(r.Row, 7) Mod 2 <> 0 And ws.Cells(r.Row, 8) Mod 2 <> 0 And ws.Cells(r.Row, 9).Value Mod 2 <> 0 Then bl = True
' UTF-8の番号を求めるためワークシート関数を入れる
' G列とI列(6列と8列)の大きい方で回転する
For i = 1 To IIf(r.Offset(, 6).Value < r.Offset(, 8).Value, r.Offset(, 8).Value, r.Offset(, 6).Value) Step 2
ws.Cells(iRow, iCol).Formula = "=DEC2HEX(UNICODE(MIDB(" & r.Address & "," & i & " ,2)))"
If bl = True And ws.Cells(iRow, iCol).Value = 20 Then
ws.Cells(iRow, iCol).Formula = "=DEC2HEX(UNICODE(MIDB(" & r.Address & "," & i & " ,1))+8173)"
i = i - 1 ' &H20だった場合は1戻す
End If
iCol = iCol + 1
Next
' 最後が&H200D = &#8205だった場合、消すために列を一つ戻す
If Val("&H" & Cells(r.Row, iCol - 1).Value) = 8205 Then iCol = iCol - 1
Cells(r.Row, iCol) = "UTF-16 Hex String Array(16)"
iCol = iCol + 1
buf = ActiveCell.Value
rst = ""
  For i = 1 To LenB(buf) Step 2
    bbArray = MidB(buf, i, 2)
   If i + 2 < LenB(buf) Then
        rst = rst & """" & IIf(Len(CStr(Hex(bbArray(1)))) = 1, "0" & Hex(bbArray(1)), Hex(bbArray(1))) & IIf(Len(CStr(Hex(bbArray(0)))) = 1, "0" & Hex(bbArray(0)), Hex(bbArray(0))) & """" & ","
   ElseIf i + 2 >= LenB(buf) Then
   rst = rst & """" & IIf(Len(CStr(Hex(bbArray(1)))) = 1, "0" & Hex(bbArray(1)), Hex(bbArray(1))) & IIf(Len(CStr(Hex(bbArray(0)))) = 1, "0" & Hex(bbArray(0)), Hex(bbArray(0))) & """"
   End If
  Next
Cells(r.Row, iCol).Value = rst
End If
Erase bbArray
bbArray = ToUTF8(buf)
End Sub

UTF-8を直接VBAのみで求めると大変難しくなるが、多少出現する列がばらけているもののワークシートを使用することで驚くほど簡単になった。
また、現在はマイナーだが、UTF-16LEの方がzwjを正確にばらせるので、トータルで見るとUTF-16LEの方が優位になっていると思われる。内部処理がUTF-16LEというのは理解できた。
サロゲートペアで出遅れたものの、今後UTF-16LEの方が復活することはあると思う。UTF-8はなぜかzwjがうまくばらせない。zwjはほかにもあるので、まだ問題はある。他方UTF-16LEはひっくり返しは面倒だが、バイトで機械的に分割していけばよい。

なお、すべての文字について検証したわけではないので、不具合があるかもしれない。

最後に

今回の💖は💖である。
これはサロゲートペアでD83D``DC96の組み合わせである。パターン2224なので、そうなる。