Excel VBA 漢数字を半角算用数字に変換

質問

アプリから取得したデータの中に、一から十八までの漢数字がありますが、これを半角算用数字に変換するのに[Replace]関数で18行記述していますが、もっと簡単にできる方法がありましたら教えてください。

回答No.7

cj_mover · ベストアンサー

＃６、ｃｊです。
＃６の補足欄見ました。
ご提示のコードを読み込んで、
「フラ盤」の棋譜データからサンプルを作り、
テストしました。

ご提示のコードで試したところ、
なんのストレスもなく、正しく動作することを確認しました。
現在のコードのままでもいいような気もしていますが、
冗長な感じが気になるのも理解できるところです。

今回の課題は「もっと簡単に」ということでしたから、
持駒の漢数字置換に関連した部分に限って、
簡単にする書き方を提示してみます。

その前にプロシージャの構成を整理しておきます。

■データ読込・整形
　●棋譜ファイル
　　▲盤面
　　　　行位置の取得
　　　　盤面要素を　出力用フォーマットに置換
　　　　最下行位置取得
　　▲持駒
　　　　行位置の取得
　　　　タイトル削除
　　　　持駒DATAを配列化
　　　　持駒要素の漢数字を半角算用数字へ置換
　　▲指手
　　　　行位置の取得
　　　　最下行から　何手詰めか取得
　　　　指手配列を　手数分で再定義
　　　　指手要素を　出力用フォーマットに置換
■データ出力
　●配置DATA
　●持駒
　●正解

ここで示すのは、▲持駒セクションの処理全体です。
構成を変えることで簡単にする可能性が増すので、
セクションごと提示します。
＃６補足欄のコードでいうと、
　　ER = Range("A1").End(xlDown).Row
と
　　C = 1
の間をすべて入れ替えると動くように書いています。

' ' ・
' ' ・
' ' ・
' ' ER = Range("A1").End(xlDown).Row
' '　　　　　■　↓　■
　　Const 漢数字1_9 = "一二三四五六七八九"　　'　　宣言部に転記してください
　　Dim arrS As Variant　　'　　宣言部に転記してください
' ' 持駒――――――――――――――――――――――――――――――
' ' 先手の持駒　行位置の取得
　　MB = Range("A:A").Find(What:="先手の持駒", LookAt:=xlPart).Row
' ' "先手の持駒："　タイトル削除
　　持駒DATA = Mid$(Cells(MB, "A"), 7)
' ' "十　"を基準に、単独の漢数字'十'を半角算用数字'10'に置換
　　持駒DATA = Trim$(Replace(持駒DATA & "　", "十　", "10　"))
' ' 漢数字'十'を半角算用数字'1'に置換
　　持駒DATA = Replace(持駒DATA, "十", "1")
' ' 漢数字'一～九'を半角算用数字'1～9'に置換
　　For N = 1 To 9
　　' ' 見つかったものだけを置換する
　　　　If InStr(持駒DATA, Mid$(漢数字1_9, N, 1)) > 0 Then 持駒DATA = Replace(持駒DATA, Mid$(漢数字1_9, N, 1), CStr(N))
　　Next N
' ' Split()関数で持駒DATAを文字列配列に
　　arrS = Split("　" & 持駒DATA, "　")
' ' 出力用配列 [持駒] に転写
　　For 行 = 1 To UBound(arrS)
　　　　If Len(arrS(行)) = 1 Then arrS(行) = arrS(行) & "1"
　　　　持駒(行) = arrS(行)
　　Next 行
' '　　　　　■　↑　■
' ' 指手――――――――――――――――――――――――――――――
' ' C = 1
' ' ・
' ' ・
' ' ・

切り分けてから置換より置換してから切り分ける方が効率いいです。

行位置の取得　の部分はFind メソッドを簡単に書いていますが、
この部分は、ご提示の方法そのままでもいいと思います。

Split()関数はＶＢＡの中でもかなり優秀な関数なので採用しましたが、
Excel2000よりも前のバージョンには用意されていません。

ところどころ、正規表現を使うと簡潔にできる部分もあります。
将来的に検討してみるのもいいと思います。

セル範囲に配列を出力する方法として、
例えば、
　v = Array("名前", Date, 980)
　Range("A1").Resize(, 3).Value = v
のように配列まるごと出力することも可能です。
完結にまとめるには有力な手法ですから、
色々試してみるといいかも知れません。

以上、参考まで。

お礼

重ねての丁重な回答をいただきましてありがとうございます

回答No.6

cj_mover

こんにちは。お邪魔します。

（＃No.1補足欄を参考にさせて頂きます。）
サブルーチンにして書きました。

　書式：　
Sub MotiGomaPrintA(ByVal Source As String, ByVal Destination As Range, _
　　　　　　　　　Optional ByVal ToRight As Boolean, _
　　　　　　　　　Optional ByVal Delimiter As String = " ")

Source には
> sheet1のセルには、"先手の持駒：角二　金四　銀四　桂二　香三　歩十五"のように入ります。"角"以下が変動します。
"先手の持駒：角二　金四　銀四　桂二　香三　歩十五"のような文字列を指定します。

Destination には
> これをsheet2のセル1に「角2」、セル2に「金4」のように切り分けます。
（セル2はセル1の下なのか右なのかわかりませんが）
この場合の'セル1'、出力先の先頭セルを指すRange型オブジェクトを指定します、

ToRight は
省略するかFalseを指定すると、縦方向、
Trueを指定すると、横方向、
に、持駒を（最大７セル）列挙して出力します。

Delimiter には
各持駒の間にある区切り文字を指定します。
省略した場合は、全角｜半角スペースが区切り文字となります。

※
"先手の持駒："の部分、タイトルには、最後の文字として
全角｜半角コロン["："|":"]が使われていることが条件です。

例示（Re8148829サンプル）は
Ｆ１セルにある持駒テキストを
Ｆ２から下（最大７セル）に
持駒ごとに切り分けた内容を半角数字に置換して出力する例です。
各パラメーターの指定は実用に合わせて調整してください。
複数セルを対象にする場合は
Source、Destination、共にループさせる必要があります。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8148829サンプル()
　　Call MotiGomaPrintA(Range("F1").Value, Range("F2"))
End Sub

Sub MotiGomaPrintA(ByVal Source As String, ByVal Destination As Range, _
　　　　　　　　　Optional ByVal ToRight As Boolean, _
　　　　　　　　　Optional ByVal Delimiter As String = " ")
　　Const 漢数字 = "一二三四五六七八九十"
　　Dim arrS
　　Dim sTmp As String
　　Dim nUB As Long, nBuf As Long, nNum As Long
　　Dim i As Long, nPos As Long

　　Source = StrConv(Source, vbNarrow)
　　Source = Mid$(Source, InStr(Source, ":") + 1)
　　If Source = "" Then Exit Sub

　　arrS = Split(Source, Delimiter)
　　nUB = UBound(arrS)
　　For i = 0 To nUB
　　　　sTmp = arrS(i)
　　　　If InStr(漢数字, Mid$(sTmp, 2, 1)) Then　　'　　●
　　　　　　nBuf = 0&
　　　　　　For nPos = 2& To Len(sTmp)
　　　　　　　　nNum = InStr(漢数字, Mid$(sTmp, nPos, 1))　　'　　▲
　　　　　　　　If nNum Then nBuf = nBuf + nNum
　　　　　　Next nPos
　　　　　　If nBuf Then arrS(i) = Left$(sTmp, 1) & nBuf
　　　　End If
　　Next i

　　With Destination
　　　　If ToRight Then
　　　　　　.Resize(1, 7).Value = Empty
　　　　　　.Resize(1, nUB + 1).Value = arrS
　　　　Else
　　　　　　.Resize(7, 1).Value = Empty
　　　　　　.Resize(nUB + 1, 1).Value = Application.Transpose(arrS)
　　　　End If
　　End With
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

もし、自作で乗り切りたいということでしたら、
コードまるごと見せてもらった方が話が早いです。
ただ、
各駒ごと、２文字めに漢数字があるならば、、、（●で示した所）
という条件分岐や、
一文字ずつ見ていって"一二三四五六七八九十"の中の
何番目にあるか、で数値化している処理、、、（▲で示した所）
など、部分的には参考になるかも知れません。

こちらの理解が至っていない気もするので、
もし違っていたら補足ください。

とりあえず、以上です。

お礼

回答いただきましてありがとうございます

補足

Option Explicit
Option Base 1

Sub DATA変換()
'
Sheets("棋譜ファイル").Select
'BR="棋譜ファイル"盤面の上枠行、ER="棋譜ファイル"の最下行、MB="棋譜ファイル"の先手の持駒行
Dim 行 As Byte, 列 As Byte, BR As Byte, ER As Integer, SR As Integer, EC As Integer, C As Integer, N As Integer, 枡(40) As Variant, MB As Byte, 持駒DATA As Variant, 持駒(7) As Variant, 指手() As Variant
For 行 = 1 To Range("A1").End(xlDown).Row
If Left(Cells(行, "A"), 1) = "+" Then BR = 行: Exit For
Next 行
N = 1
For 行 = BR + 1 To BR + 9
For 列 = 2 To 18 Step 2
If Mid(Cells(行, "A"), 列, 2) <> " ・" Then
枡(N) = CStr(行 - BR) & CStr(列 / 2) & Mid(Cells(行, "A"), 列, 2)
枡(N) = Replace(枡(N), " ", "先")
枡(N) = Replace(枡(N), "v", "後")
枡(N) = Replace(枡(N), "杏", "成香")
枡(N) = Replace(枡(N), "圭", "成桂")
枡(N) = Replace(枡(N), "全", "成銀")
N = N + 1
End If
Next 列
Next 行
ER = Range("A1").End(xlDown).Row
For 行 = 1 To ER
If Left(Cells(行, "A"), 5) = "先手の持駒" Then MB = 行: Exit For
Next 行
持駒DATA = Replace(Cells(MB, "A"), "先手の持駒：", "")
For 行 = 1 To 7
If InStr(持駒DATA, "　") <> 0 Then
持駒(行) = Left(持駒DATA, InStr(持駒DATA, "　") - 1)
持駒DATA = Mid(持駒DATA, InStr(持駒DATA, "　") + 1)
ElseIf InStr(持駒DATA, "　") = 0 Then
持駒(行) = 持駒DATA: Exit For
End If
Next 行
For 行 = 1 To 7
If 持駒(行) = "" Then Exit For
持駒(行) = Replace(持駒(行), "十一", 11)
持駒(行) = Replace(持駒(行), "十二", 12)
持駒(行) = Replace(持駒(行), "十三", 13)
持駒(行) = Replace(持駒(行), "十四", 14)
持駒(行) = Replace(持駒(行), "十五", 15)
持駒(行) = Replace(持駒(行), "十六", 16)
持駒(行) = Replace(持駒(行), "十七", 17)
持駒(行) = Replace(持駒(行), "十八", 18)
持駒(行) = Replace(持駒(行), "一", 1)
持駒(行) = Replace(持駒(行), "二", 2)
持駒(行) = Replace(持駒(行), "三", 3)
持駒(行) = Replace(持駒(行), "四", 4)
持駒(行) = Replace(持駒(行), "五", 5)
持駒(行) = Replace(持駒(行), "六", 6)
持駒(行) = Replace(持駒(行), "七", 7)
持駒(行) = Replace(持駒(行), "八", 8)
持駒(行) = Replace(持駒(行), "九", 9)
持駒(行) = Replace(持駒(行), "十", 10)
If Len(持駒(行)) = 1 Then 持駒(行) = 持駒(行) & 1
Next 行
C = 1
For 行 = 1 To ER
If Cells(行, "A") = "手数----指手---------消費時間--" Then SR = 行: Exit For
Next 行
EC = Val(Mid(Cells(ER, "A"), 3))
ReDim 指手(EC)
For 行 = SR + 1 To SR + EC
指手(C) = Mid(Cells(行, "A"), 6)
指手(C) = Replace(指手(C), "　", "")
指手(C) = Replace(指手(C), " ", "")
指手(C) = Replace(指手(C), "打", "")
指手(C) = Left(指手(C), InStrRev(指手(C), "(") - 1)
指手(C) = Replace(指手(C), "(", "")
指手(C) = Replace(指手(C), ")", "")
If Left(指手(C), 1) = "同" Then 指手(C) = Left(指手(C - 1), 2) & Mid(指手(C), 2)
指手(C) = Switch(Mid(指手(C), 2, 1) = "一", 1, Mid(指手(C), 2, 1) = "二", 2, Mid(指手(C), 2, 1) = "三", 3, Mid(指手(C), 2, 1) = "四", 4, Mid(指手(C), 2, 1) = "五", 5, Mid(指手(C), 2, 1) = "六", 6, _
Mid(指手(C), 2, 1) = "七", 7, Mid(指手(C), 2, 1) = "八", 8, Mid(指手(C), 2, 1) = "九", 9) & Switch(Left(指手(C), 1) = 1, 1, Left(指手(C), 1) = 2, 2, Left(指手(C), 1) = 3, 3, Left(指手(C), 1) = 4, 4, _
Left(指手(C), 1) = 5, 5, Left(指手(C), 1) = 6, 6, Left(指手(C), 1) = 7, 7, Left(指手(C), 1) = 8, 8, Left(指手(C), 1) = 9, 9) & Mid(指手(C), 3)
C = C + 1
Next 行
Sheets("配置DATA").Select
列 = 1
For N = 1 To 1000
If Cells(N, "A") = "" Then 行 = N: Exit For
Next N
For N = 1 To 40
If 枡(N) = "" Then Exit For
Cells(行, 列) = 枡(N): 列 = 列 + 1
Next N
Sheets("持駒").Select
列 = 1
For N = 1 To 1000
If Cells(N, "A") = "" Then 行 = N: Exit For
Next N
For N = 1 To 7
If 枡(N) = "" Then Cells(行, "A") = "なし": Exit For
Cells(行, 列) = 持駒(N): 列 = 列 + 1
Next N
Sheets("正解").Select
列 = 1
For N = 1 To 1000
If Cells(N, "A") = "" Then 行 = N: Exit For
Next N
For 列 = 1 To EC
Cells(行, 列) = 指手(列)
Next 列
'
End Sub
詰将棋問題1問を駒配置sheet、持駒sheet、正解sheetの各1行に転記しています。

回答No.5

mt2008

> このように切り分けてありますが、Cellsを持駒(行)に変えればいいのでしょうか

Sheet1の内容をSheet2に貼り付けてください。
そして、ANo.4のマクロを走らせると、Sheet2上の漢数字を全て半角数字に変換します。
その後で切り分ければよいかと思います。

お礼

回答いただきましてありがとうございます。
For 行 = 1 To 7
If 持駒(行) = "" Then Exit For
持駒(行) = Replace(持駒(行), "十一", 11)
持駒(行) = Replace(持駒(行), "十二", 12)
持駒(行) = Replace(持駒(行), "十三", 13)
持駒(行) = Replace(持駒(行), "十四", 14)
持駒(行) = Replace(持駒(行), "十五", 15)
持駒(行) = Replace(持駒(行), "十六", 16)
持駒(行) = Replace(持駒(行), "十七", 17)
持駒(行) = Replace(持駒(行), "十八", 18)
持駒(行) = Replace(持駒(行), "一", 1)
持駒(行) = Replace(持駒(行), "二", 2)
持駒(行) = Replace(持駒(行), "三", 3)
持駒(行) = Replace(持駒(行), "四", 4)
持駒(行) = Replace(持駒(行), "五", 5)
持駒(行) = Replace(持駒(行), "六", 6)
持駒(行) = Replace(持駒(行), "七", 7)
持駒(行) = Replace(持駒(行), "八", 8)
持駒(行) = Replace(持駒(行), "九", 9)
持駒(行) = Replace(持駒(行), "十", 10)
If Len(持駒(行)) = 1 Then 持駒(行) = 持駒(行) & 1
Next 行
切り分けてから上のように変換して転記していました。

回答No.4

mt2008

ごめんなさい、No.3の回答では十の時1になってしまいますね。
やはり18回のReplaceが良いと思います。

Sub Sample2()
　　Sheets("Sheet2").Select
　　For i = 18 To 1 Step -1
　　　　Cells.Replace What:=Evaluate("NUMBERSTRING(" & i & ", 1)"), Replacement:=CStr(i)
　　Next i
End Sub

お礼

回答いただきましてありがとうございます。

補足

持駒DATA=Replace(Cells(MB, "A"),"先手の持駒：","")
For 行 = 1 To 7
If InStr(持駒DATA,"　") <> 0 Then
持駒(行)=Left(持駒DATA,InStr(持駒DATA,"　")-1)
持駒DATA=Mid(持駒DATA,InStr(持駒DATA,"　")+1)
ElseIf InStr(持駒DATA,"　") = 0 Then
持駒(行) = 持駒DATA: Exit For
End If
Next 行
このように切り分けてありますが、Cellsを持駒(行)に変えればいいのでしょうか。

回答No.3

mt2008

ANo.2です。

No.1の方への補足を観ました。
Sheet2全体を対象とするならReplaceを使う事になると思いますが、以下の様にすれば合計10回のReplaceで済みます。
Sub Sample()
　　Sheets("Sheet2").Select
　　For i = 1 To 10
　　　　Cells.Replace What:=Evaluate("NUMBERSTRING(" & i & ", 1)"), Replacement:=Left(CStr(i), 1)
　　Next i
End Sub

お礼

回答いただきましてありがとうございます。

回答No.2

mt2008

セル関数NUMBERSTRINGを使用してみました。一～十八以外は0が返ります。

Sub test()
　　MsgBox fNumberK("十八")
End Sub
Function fNumberK(sKnum As String) As Long
　　fNumberK = 0
　　For i = 1 To 18
　　　　If sKnum = Evaluate("NUMBERSTRING(" & i & ", 1)") Then
　　　　　　fNumberK = i
　　　　　　Exit Function
　　　　End If
　　Next i
End Function

お礼

回答いただきましてありがとうございます。

回答No.1

misatoanna

一から十八までの漢数字がセルに単体で入っているのでしたら、漢数字のセルを一括選択して以下を実行するというのはいかがでしょうか。

Sub Test()
　Dim splA, splB, rng, r
　Const A = "一,二,三,四,五,六,七,八,九,十,十一,十二,十三,十四,十五,十六,十七,十八"
　Const B = "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18"
　splA = Split(A, ",")
　splB = Split(B, ",")
　For Each rng In Selection
　　For r = 0 To UBound(splA)
　　　If rng.Value = splA(r) Then Exit For
　　Next
　　rng.Value = splB(r)
　Next
End Sub

お礼

早々に回答いただきましてありがとうございます。

補足

sheet1のセルには、"先手の持駒：角二　金四　銀四　桂二　香三　歩十五"のように入ります。"角"以下が変動します。
これをsheet2のセル1に「角2」、セル2に「金4」のように切り分けます。