[VBA] 漢数字を算用数字に変換

0.README.md

[VBA] 漢数字を算用数字に変換

【お題】 VBAで漢数字を算用数字に変換してください。

例:千八百万六千五百→18,006,500

カンマはあってもなくてもよいです。オプションで選べるとなおよし。皆さんどんな解答作りますか？

#VBA #Excel

-- Aito@Kabura_net14831

あんまりスマートでないですが、晒しておきます……。
[2022/07/12追記] どうもRegExpを使うとパフォーマンスが悪いみたいなので、使わないバージョンも試作。

ソースコード

• Kansuuji2Number()用標準モジュール（※正規表現RegExp使用）
• Kansuu2Number()用標準モジュール（※正規表現未使用）
• カンマ挿入プロシージャ用標準モジュール（※RegExp使用時と未使用時のパフォーマンス比較用）

ModInsertSeparator.vba

Option Explicit

Function InsertSeparator(ByVal Number, Optional PerDigit = 3, Optional Separator = ",")
    If TypeName(Number) <> "String" Then Number = WorksheetFunction.Text(Number, "0") ' 指数表現を数値並びに変換
    Dim NumberLength As Long: NumberLength = Len(Number)
    Dim MaxIndex As Long: MaxIndex = Fix((NumberLength + PerDigit - 1) / PerDigit)
    Dim SepList: ReDim SepList(1 To MaxIndex)
    Dim Index As Long
    For Index = MaxIndex To 1 Step -1
        SepList(Index) = Right(Number, PerDigit)
        NumberLength = NumberLength - PerDigit
        If 0 < NumberLength Then Number = Left(Number, NumberLength)
    Next
    InsertSeparator = Join(SepList, Separator)
End Function

Function InsertSeparatorR(ByVal Number, Optional PerDigit = 3, Optional Separator = ",")
    Static Reg As Object: If Reg Is Nothing Then Set Reg = CreateObject("VBScript.RegExp"): Reg.Global = True: Reg.MultiLine = False
    If TypeName(Number) <> "String" Then Number = WorksheetFunction.Text(Number, "0") ' 指数表現を数値並びに変換
    Reg.Pattern = "\B(?=(\d{" & PerDigit & "})+(?!\d))"
    InsertSeparatorR = Reg.Replace(Number, Separator)
End Function

Sub TestInsertSeparator()
    Const TestCount = 100000
    Const TestNumber = "123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890"
    Dim StartTime, Counter
    StartTime = Timer
    Debug.Print "InsertSeparator(""" & TestNumber & """)"
    Debug.Print " => " & InsertSeparator(TestNumber)
    For Counter = 1 To TestCount: Call InsertSeparator(TestNumber): Next
    Debug.Print Format(Timer - StartTime, "00:00:00.000")
    StartTime = Timer
    Debug.Print "InsertSeparatorR(""" & TestNumber & """)"
    Debug.Print " => " & InsertSeparatorR(TestNumber)
    For Counter = 1 To TestCount: Call InsertSeparatorR(TestNumber): Next
    Debug.Print Format(Timer - StartTime, "00:00:00.000")
End Sub

ModKansuu2Number.vba

Option Explicit

' 【お題】 https://twitter.com/Kabura_net14831/status/1546078899955965952
' ソースコード: https://gist.github.com/furyutei/15ad4d9836161cc00f743126c5232438#file-modkansuu2number-vba

Function Kansuu2Number(ByVal Kansuuji As String, Optional InsertComma As Boolean = True)
    Const DigitPerUnit = 4
    Static UnitList, UnitCount As Long, FormatString
    If IsEmpty(UnitList) Then
        UnitList = VBA.Split("無量大数,不可思議,那由他,阿僧祇,恒河沙,極,載,正,澗,溝,穣," & ChrW(&H79ED) & ",垓,京,兆,億,万", ",")
        UnitCount = UBound(UnitList) - LBound(UnitList) + 1
        FormatString = String(DigitPerUnit, "0")
    End If
    Kansuuji = ConvertVariant(Trim(Kansuuji))
    Dim Number As String
    Dim Unit, WorkPair, LeftIndex As Long, RightIndex As Long
    Dim WorkDigitCount As Long: WorkDigitCount = DigitPerUnit * UnitCount
    Dim WorkUnitDigit As Long
    For Each Unit In UnitList
        WorkPair = VBA.Split(Kansuuji, Unit, 2)
        LeftIndex = LBound(WorkPair): RightIndex = UBound(WorkPair)
        If RightIndex - LeftIndex + 1 = 2 Then
            WorkUnitDigit = ToUnitDigit(WorkPair(LeftIndex))
            If Number = "" Then
                Number = WorkUnitDigit & String(WorkDigitCount, "0")
            Else
                Mid(Number, Len(Number) - WorkDigitCount - DigitPerUnit + 1, DigitPerUnit) = Format(WorkUnitDigit, FormatString)
            End If
            Kansuuji = WorkPair(RightIndex)
        End If
        WorkDigitCount = WorkDigitCount - 4
    Next
    If Kansuuji <> "" Then
        WorkUnitDigit = ToUnitDigit(Kansuuji)
        If Number = "" Then
            Number = CStr(WorkUnitDigit)
        Else
            Mid(Number, Len(Number) - DigitPerUnit + 1, DigitPerUnit) = Format(ToUnitDigit(Kansuuji), FormatString)
        End If
    End If
    If InsertComma Then Number = InsertSeparator(Number)
    Kansuu2Number = Number
End Function

Private Function ConvertVariant(ByVal Kansuuji)
    Static Pairs
    If IsEmpty(Pairs) Then Pairs = VBA.Split("那由多,那由他,阿僧祗,阿僧祇,潤,澗,杼," & ChrW(&H79ED) & "," & ChrW(&HD855) & ChrW(&HDF71) & "," & ChrW(&H79ED) & ",萬,万,阡,千,拾,十,参,三,弐,二,壱,一,零,〇", ",")
    Dim Index: For Index = LBound(Pairs) To UBound(Pairs) Step 2: Kansuuji = Replace(Kansuuji, Pairs(Index), Pairs(Index + 1)): Next
    ConvertVariant = Kansuuji
End Function

Private Function ToUnitDigit(ByVal Kansuuji) As Long
    Static UnitList, UnitCount As Long
    If IsEmpty(UnitList) Then UnitList = VBA.Split("千,百,十", ","): UnitCount = UBound(UnitList) - LBound(UnitList) + 1
    If Kansuuji = "" Then ToUnitDigit = 1: Exit Function
    Dim Unit, WorkPair, LeftIndex As Long, RightIndex As Long
    Dim UnitFactor As Long: UnitFactor = 10 ^ UnitCount
    For Each Unit In UnitList
        WorkPair = VBA.Split(Kansuuji, Unit, 2)
        LeftIndex = LBound(WorkPair): RightIndex = UBound(WorkPair)
        If RightIndex - LeftIndex + 1 = 2 Then
            ToUnitDigit = ToUnitDigit + ToDigit(WorkPair(LeftIndex)) * UnitFactor
            Kansuuji = WorkPair(RightIndex)
        End If
        UnitFactor = UnitFactor / 10
    Next
    If Kansuuji <> "" Then ToUnitDigit = ToUnitDigit + ToDigit(Kansuuji)
End Function

Private Function ToDigit(ByVal Kan1) As Long
    If Kan1 = "" Then
        ToDigit = 1
    Else
        ToDigit = InStr("〇一二三四五六七八九", Kan1) - 1
    End If
End Function

Private Function InsertSeparator(ByVal Number, Optional PerDigit = 3, Optional Separator = ",")
    If TypeName(Number) <> "String" Then Number = WorksheetFunction.Text(Number, "0") ' 指数表現を数値並びに変換
    Dim NumberLength As Long: NumberLength = Len(Number)
    If NumberLength < 1 Then Exit Function
    Dim MaxIndex As Long: MaxIndex = Fix((NumberLength + PerDigit - 1) / PerDigit)
    Dim SepList: ReDim SepList(1 To MaxIndex)
    Dim Index As Long
    For Index = MaxIndex To 1 Step -1
        SepList(Index) = Right(Number, PerDigit)
        NumberLength = NumberLength - PerDigit
        If 0 < NumberLength Then Number = Left(Number, NumberLength)
    Next
    InsertSeparator = Join(SepList, Separator)
End Function

ModKansuuji2Number.vba

Option Explicit

' 【お題】 https://twitter.com/Kabura_net14831/status/1546078899955965952
' ソースコード: https://gist.github.com/furyutei/15ad4d9836161cc00f743126c5232438#file-modkansuuji2number-vba

' ※「Microsoft VBScript Regular Expressions 5.5」への参照設定が必要

Function Kansuuji2Number(ByVal Kansuuji As String, Optional InsertComma As Boolean = True)
    Const DigitPerUnit = 4
    Static Unit2Digit As Collection, RegUnits, InitResult
    If Unit2Digit Is Nothing Then
        Dim Units: Units = VBA.Split("万,億,兆,京,垓," & ChrW(&H79ED) & ",穣,溝,澗,正,載,極,恒河沙,阿僧祇,那由他,不可思議,無量大数", ",")
        RegUnits = "($|" & Join(Units, "|") & ")"
        Dim WorkDigit: WorkDigit = 0
        Dim WorkUnit
        Set Unit2Digit = New Collection
        Unit2Digit.Add WorkDigit, Key:="": For Each WorkUnit In Units: WorkDigit = WorkDigit + DigitPerUnit: Unit2Digit.Add WorkDigit, Key:=WorkUnit: Next
        InitResult = String(WorkDigit + DigitPerUnit, "0")
    End If
    Kansuuji = ConvertVariant(Trim(Kansuuji))
    Dim Result: Result = InitResult
    With New RegExp ' CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = False
        .Pattern = "(.*?)" & RegUnits
        Dim MatchParts, MatchPart: Set MatchParts = .Execute(Kansuuji)
        For Each MatchPart In MatchParts
            If MatchPart.SubMatches(0) <> "" Or MatchPart.SubMatches(1) <> "" Then
                Mid(Result, Len(Result) - Unit2Digit(MatchPart.SubMatches(1)) - DigitPerUnit + 1, DigitPerUnit) = ToFourDigit(MatchPart.SubMatches(0))
            End If
        Next
        .Pattern = "^0+(?!$)": Result = .Replace(Result, "")
        If InsertComma Then .Pattern = "\B(?=(\d{3})+(?!\d))": Result = .Replace(Result, ",")
    End With
    Kansuuji2Number = Result
End Function

Private Function ConvertVariant(ByVal Kansuuji)
    Static Pairs
    If IsEmpty(Pairs) Then Pairs = VBA.Split("那由多,那由他,阿僧祗,阿僧祇,潤,澗,杼," & ChrW(&H79ED) & "," & ChrW(&HD855) & ChrW(&HDF71) & "," & ChrW(&H79ED) & ",萬,万,阡,千,拾,十,参,三,弐,二,壱,一,零,〇", ",")
    Dim Index: For Index = LBound(Pairs) To UBound(Pairs) Step 2: Kansuuji = Replace(Kansuuji, Pairs(Index), Pairs(Index + 1)): Next
    ConvertVariant = Kansuuji
End Function

Private Function ToFourDigit(ByVal Kansuuji)
    Dim Digits: Digits = VBA.Array(0, 0, 0, 0)
    If Kansuuji = "" Then Digits(0) = 1: GoTo CLEANUP
    Dim Locate, Kan1, Digit, Index: Index = 0
    For Locate = Len(Kansuuji) To 1 Step -1
        Kan1 = Mid(Kansuuji, Locate, 1): Digit = 1
        Select Case Kan1
            Case "十": Index = 1
            Case "百": Index = 2
            Case "千": Index = 3
            Case Else: Digit = ToDigit(Kan1)
        End Select
        Digits(Index) = Digit
    Next

CLEANUP:
    ToFourDigit = Digits(3) & Digits(2) & Digits(1) & Digits(0)
End Function

Private Function ToDigit(ByVal Kan1)
    Static NumMap As Collection
    If NumMap Is Nothing Then
        Set NumMap = New Collection
        Dim KanNumList: KanNumList = VBA.Split("〇,一,二,三,四,五,六,七,八,九", ",")
        Dim WorkKanNum, WorkNum: WorkNum = 0: For Each WorkKanNum In KanNumList: NumMap.Add WorkNum, Key:=WorkKanNum: WorkNum = WorkNum + 1: Next
    End If
    ToDigit = NumMap(Kan1)
End Function