サロゲートペアに対応した自作関数（Len,Left,Mid,Right）

公開日：2022-06-24　最終更新日：2025-02-07

サロゲートペアに対応した自作関数（Len,Left,Mid,Right）

ツイッターで、サロゲートペアに対応した文字列関数の話しになりました。

シート関数のLEFTとRIGHTはサロゲートペアに対応しているようですが、MIDとLENは対応していません。
（シート関数のLEFTとRIGHTはページ最後の使用例の中にも出てきます。）
そして、VBA関数の、Len,Left,Mid,Right、これらは一切サロゲートペアに対応していません。
これが必要になることもほとんどないのですが、ツイッターで話したついでなので関数を自作してみました。

こういういきさつなので、特に凝ったVBAを作成したわけではありませんし、厳密なテストもしていません。
とりあえず作って見たので、残しておく意味でここに掲載しておくことにしました。

サロゲートペアとは

簡単に言うと、UNICODEの2文字分で1文字を表すものです。
通常2バイトで1文字のところ、4バイトで1文字になっています。
𩸽
𠮟
これらはサロゲートペア文字です。

※サロゲートペアについての詳細はネットで検索してください。

4バイトを超えるマルチバイト文字

4バイトでも足らなくて?、さらにもっと多くのバイト数を使っているものもあります。
🙇‍♂️
🙅‍♂️

今回は、これらには対応していません。
もう、ここまでくると、わけわからない・・・

以下2通り書いてみて、どちらが良いとも言えないので、両方残すことにしました。

サロゲートペアに対応した文字列関数のVBA、その1


  
    
      Function xLen(ByVal s As String) As Long

      　　Dim i As Long, cnt As Long

      　　i = 1: cnt = 0

      　　Do While i <= Len(s)

      　　　　If i < Len(s) Then

      　　　　　　If isSurrogatePair(Mid(s, i, 2)) Then

      　　　　　　　　i = i + 1

      　　　　　　End If

      　　　　End If

      　　　　cnt = cnt + 1

      　　　　i = i + 1

      　　Loop

      　　xLen = cnt

      End Function


      Function xMid(ByVal s As String, ByVal st As Long, Optional ByVal ln As Long = 0) As String

      　　If ln = 0 Then ln = Len(s)

      　　Dim cnt As Long

      　　cnt = 1

      　　Do While xLen(Left(s, cnt)) < st And cnt <= Len(s)

      　　　　cnt = cnt + 1

      　　Loop

      　　Do While xLen(xMid) < ln And cnt <= Len(s)

      　　　　xMid = xMid & Mid(s, cnt, 1)

      　　　　If cnt < Len(s) Then

      　　　　　　If isSurrogatePair(Mid(s, cnt, 2)) Then

      　　　　　　　　xMid = xMid & Mid(s, cnt + 1, 1)

      　　　　　　　　cnt = cnt + 1

      　　　　　　End If

      　　　　End If

      　　　　cnt = cnt + 1

      　　Loop

      End Function


      Function xLeft(ByVal s As String, ByVal ln As Long) As String

      　　xLeft = xMid(s, 1, ln)

      End Function


      Function xRight(ByVal s As String, ByVal ln As Long) As String

      　　xRight = xMid(s, xLen(s) - ln + 1)

      End Function


      Function isSurrogatePair(ByVal s As String)

      　　Dim b() As Byte: b = s

      　　Dim h1 As Long, h2 As Long

      　　isSurrogatePair = False

      　　h1 = b(0) + b(1) * 256&

      　　h2 = b(2) + b(3) * 256&

      　　If h1 >= &HD800& And h1 <= &HDBFF& And _

      　　　 h2 >= &HDC00& And h2 <= &HDFFF& Then

      　　　 isSurrogatePair = True

      　　End If

      End Function

サロゲートペアに対応した文字列関数のVBA、その2


  
    
      Function xLen(ByVal s As String) As Long

      　　Dim b() As Byte: b = s

      　　Dim i As Long

      　　For i = LBound(b) To UBound(b) Step 2

      　　　　If isSurrogatePair(b, i) Then

      　　　　　　i = i + 2

      　　　　End If

      　　　　xLen = xLen + 1

      　　Next

      End Function


      Function xMid(ByVal s As String, ByVal st As Long, Optional ByVal ln As Long = 0) As String

      　　If ln = 0 Then ln = Len(s)

      　　Dim b() As Byte: b = s

      　　Dim bOut() As Byte, iOut As Long

      　　Dim i As Long, j As Long, cnt As Long


      　　For i = LBound(b) To UBound(b) Step 2

      　　　　cnt = cnt + 1

      　　　　If cnt >= st Then

      　　　　　　For j = i To i + IIf(isSurrogatePair(b, i), 3, 1)

      　　　　　　　　ReDim Preserve bOut(iOut)

      　　　　　　　　bOut(iOut) = b(j)

      　　　　　　　　iOut = iOut + 1

      　　　　　　Next

      　　　　End If

      　　　　If xLen(bOut) >= ln Then Exit For

      　　　　If isSurrogatePair(b, i) Then i = i + 2

      　　Next

      　　xMid = bOut

      End Function


      Function xLeft(ByVal s As String, ByVal ln As Long) As String

      　　xLeft = xMid(s, 1, ln)

      End Function


      Function xRight(ByVal s As String, ByVal ln As Long) As String

      　　xRight = xMid(s, xLen(s) - ln + 1)

      End Function


      Function isSurrogatePair(ByRef b() As Byte, ByVal i As Long)

      　　Dim h1 As Long, h2 As Long

      　　isSurrogatePair = False

      　　If i > UBound(b) - 3 Then Exit Function

      　　h1 = b(i) + b(i + 1) * 256&

      　　h2 = b(i + 2) + b(i + 3) * 256&

      　　If h1 >= &HD800& And h1 <= &HDBFF& And _

      　　　 h2 >= &HDC00& And h2 <= &HDFFF& Then

      　　　 isSurrogatePair = True

      　　End If

      End Function

AscWのサロゲートペア対応版

シート関数のUNICODE関数もVBAのAscW関数もサロゲートペアに対応してません。
文字コードを調べる時に不便な時もあるので、ついでにAscWのサロゲートペア対応版も作成しておきました。


  
    
      Function xAscW(ByVal s As String, Optional ByVal aPre As String = "0x", Optional ByVal aDelimit As String = " ") As String

　　Dim b() As Byte, i As Long, sRtn As String

　　b = s

　　For i = 0 To UBound(b) Step 2

　　　　sRtn = sRtn & aPre & Right("0000" & Hex(b(i + 1) * 256& + b(i)), 4) & aDelimit

　　Next

　　If Right(sRtn, 1) = aDelimit Then

　　　　sRtn = Left(sRtn, Len(sRtn) - 1)

　　End If

　　xAscW = sRtn

End Function

😅
この文字をxAscW関数に入れた結果は以下になります。
0xD83E 0xDD23

さらに、上のxAscW関数で作製したサロゲートペアの文字コードを元の文字に変換する関数も作成しておきました。
ChrW関数の引数に16進を指定できるようにしたサロゲートペア対応版ということになります。


  
    
      Function xChrW(ByVal s As String) As String

      　　If s Like "U+*" And Len(s) <= 8 Then

　　　　xChrW = WorksheetFunction.Unichar(CLng("&H" & Mid(s, 3)))

　　　　Exit Function

　　End If

　　

　　Dim b() As Byte, n As Long

　　Dim i As Long, ix As Long

　　s = Replace(s, " ", "")

　　s = Replace(s, "0x", "")

　　s = Replace(s, "U+", "")

　　ReDim b(LenB(s) / 2)

　　For ix = 1 To Len(s) Step 4

　　　　n = CLng("&H" & Mid(s, ix, 4))

　　　　i = CInt(ix / 2)

　　　　b(i) = n Mod 256

　　　　b(i + 1) = n \ 256

　　Next

　　xChrW = b

      End Function

以下のようなU+と0xに対応出来ています。
U+1F440
U+261D U+FE0F
0xD83E 0xDD23

字形選択子（異体字セレクタ）

文字の字体をより詳細に指定するためのセレクタ (選択子) です。
上に掲載したVBAを実際に使用したときに、字形選択子（異体字セレクタ）が考慮されていないために不都合がありました。
☑️
具体的にはこのような文字になります。
詳しく調べていくと、字形選択子（異体字セレクタ）はかなり数が多いようです。
そこで取り急ぎ良く使う、
FE00～FE0F
この範囲だけサロゲートペアの判定に入れて使うことにしました。


  
    
      Function isSurrogatePair(ByRef b() As Byte, ByVal i As Long)

　Dim h1 As Long, h2 As Long

　isSurrogatePair = False

　If i > UBound(b) - 3 Then Exit Function

　h1 = b(i) + b(i + 1) * 256&

　h2 = b(i + 2) + b(i + 3) * 256&

　If h1 >= &HD800& And h1 <= &HDBFF& And _

　　h2 >= &HDC00& And h2 <= &HDFFF& Then

　　isSurrogatePair = True

　End If

      　If h2 >= &HFE00& And h2 <= &HFE0F& Then

　　isSurrogatePair = True

　End If

End Function

シートでの使用例

同じテーマ「ツイッター出題回答」の記事

ツイッターで出されたVBAのお題（悪魔のCSV）をやってみた
 「VBAで導関数を求めよ」ツイッターのお題をやってみた
 ツイッターのお題「君の名は？」
ツイッターのお題「CSV編集」
アルファベットの26進（ツイッターお題）
ナンバープレート数字遊び：ツイッターお題
サロゲートペアに対応した自作関数（Len,Left,Mid,Right）
迷路にネコが挑戦したら、どうなるかな…
迷路ネコが影分身の術を体得したら…
VBAで漢数字を算用数字に変換

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
エクセル全般
ツイッター出題回答
サロゲートペアに対応した自作関数（Len,Left,Mid,Right）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

ツイッター出題回答
サロゲートペアに対応した自作関数（Len,Left,Mid,Right）