Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2013)
漢数字を半角英数の数値へ変換するプログラム
投稿日時: 20/06/08 17:06:53
投稿者: QooApp

目標
functionへstring型の漢数字の文字列(数値部分のみで最大5桁まで)を与え、
戻り値として半角の数字で数字を戻したいです。
 
<<<<漢数字の表記例>>>>
一二三   >123
百二十三  >123
百十    >110
一一〇   >110
一一零   >110
一万二千四 >12004
九万七百二 >90702
 
対象文字
一二三四五六七八九〇零 > 12345678900
十百千万 > 必要に応じて桁処理
 
 
 
大字の無い表記法「一二三」は何ら問題なくReplaceで全部変換するのですが、
大字のある表記法でプログラムのソースコードが例外処理の塊になっております。
 
 
正規表現で[十百千万]があるのか、
前後が数字のとき、どう処理するのか
ここの部分のプログラムが長すぎて技量の限界を感じています。
 
この部分のロジックで私よりマシなプログラムを探しいます。
エクセルは2013です。
 
漢数字の値としてマイナスは存在しません。
 
よろしくお願いいたします。

投稿日時: 20/06/08 17:16:40
投稿者: QooApp

追加で失礼します。
  
以下のエラー値が入った場合はエラー値(-1)を戻り値で設定したいです。
  
「一万二三四五六」> 万の桁以下に5桁ある(千百十も同様)

回答
投稿日時: 20/06/08 18:28:43
投稿者: WinArrow
投稿者のウェブサイトに移動

↓のページを参考に
VBAコードを検討してみてください。
https://yama-3.net/excel/kan2num

回答
投稿日時: 20/06/09 06:31:06
投稿者: simple

正規表現を使用した例です。
mainを実行すると、下記のように出力されます。
 

一二三                             → 123
百二十三                           → 123
百十                               → 110
一一〇                             → 110
一一零                             → 110
一万二千四                         → 12,004
九万七百二                         → 90,702
十兆二千十億三千五百万四千三百     → 10,201,035,004,300
(なお、数値は見やすさを考慮して、Formatしていますが、
  そのあたりは適宜修正して下さい。)
 
以下、参考コードです。
Option Explicit
Dim re As Object
Dim re2 As Object

Sub main()
    Dim testCase As Variant, e As Variant
    
    Set re = CreateObject("VBScript.RegExp")
    Set re2 = CreateObject("VBScript.RegExp")
    'テスト検証
    testCase = Array("一二三", "百二十三", "百十", "一一〇", _
                    "一一零", "一万二千四", "九万七百二", _
                    "十兆二千十億三千五百万四千三百")
    For Each e In testCase
        Debug.Print CStr(e); Tab(36); "→ "; Format(convert(CStr(e)), "#,000")
    Next
End Sub

Function convert(s As String) As Double
    Dim matches As Object
    Dim k       As Long
    Dim sk      As String
    Dim vk      As Double
    Dim total   As Double
    Dim unit    As Variant

    unit = Array(10 ^ 12, 10 ^ 8, 10 ^ 4)
    re.Pattern = "^(.*?兆)?(.*?億)?(.*?万)?(.*?)$"
    Set matches = re.Execute(s)
    If matches.Count > 0 Then
        '兆、億、万の位 -------------------
        For k = 0 To 2
            sk = matches(0).SubMatches(k)
            If sk <> "" Then
                sk = Left(sk, Len(sk) - 1)
                vk = convert2(sk) * unit(k) 'それぞれは千以下のロジックを使う
                total = total + vk
            End If
        Next
        '千の位以下 ------------------------
        sk = matches(0).SubMatches(3)
        total = total + convert2(sk)
    End If
    convert = total
End Function

'千の位以下の処理
Function convert2(s As String) As Variant
    Dim matches As Object
    Dim k       As Long
    Dim sk      As String
    Dim vk      As Long
    Dim total   As Long
    Dim unit    As Variant

    unit = Array(10 ^ 3, 10 ^ 2, 10, 1)
    
    re2.Pattern = "^(.*?千)?(.*?百)?(.*?十)?(.*?)$"
    Set matches = re2.Execute(s)
    If matches.Count > 0 Then
        '千、百、十部分
        For k = 0 To 2
            sk = matches(0).SubMatches(k)
            If sk <> "" Then
                sk = Left(sk, Len(sk) - 1)    '単位をとる
                If sk = "" Then
                    vk = 1 * unit(k)
                Else
                    vk = myReplace(sk) * unit(k)
                End If
                total = total + vk
            End If
        Next
        '十円未満、もしくは位数のないもの-----------------
        sk = matches(0).SubMatches(3)
        If sk <> "" Then
            vk = myReplace(sk)
            total = total + vk
        End If
    End If
    convert2 = total
End Function

'漢数字を数字に変換
Function myReplace(s As String) As Double
    Const kansuuji As String = "一二三四五六七八九〇零"
    Const nums As String = "12345678900"
    Dim k As Long

    For k = 1 To Len(kansuuji)
        s = Replace(s, Mid(kansuuji, k, 1), Mid(nums, k, 1))
    Next
    myReplace = Val(s)
End Function

なお、エラー対応等は、そちらで工夫してください。

投稿日時: 20/06/09 09:59:23
投稿者: QooApp

WinArrow 様
 速攻でご返信いただきありがとうございます。
 こういうやり方もあるんですね。ちょっと試させていただきます。
 
simple  様
 万までで大丈夫だったのですがわざわざ億や兆まで作成していただき勉強になりました。
 動作もしましたのでとりあえずはこちらを採用させていただきます。
 コメントまで細かくご説明いただきありがとうございます。
 
お二方様、素早いご連絡いただきありがとうございます。

投稿日時: 20/06/09 10:37:28
投稿者: QooApp

私の中の求めるものは解決しましたので閉会させていただきます。
ありがとうございました。