VBAで旧字体を異字体に一括で変換するコードについて

エクセル2016を使っております。
あるファイルで氏名でVLOOKUP関数を使い値を取得したいのですが、旧字体・異字体が混ざっており、適切に値が取得できません。

VBAで一括変換したく、ネットで調べながら以下のコードをThisworkbookのモジュールに書いて実行したのですが、動きません。
いろいろとおかしいと思うので、ご教示願います。


Sub macro1()
Dim str As String
Call ChangeName
End Sub

Function ChangeName() As String
strName = Replace(strName, "　", "") '全角空白を半角空白に変換
strName = Replace(strName, "髙", "高")
strName = Replace(strName, "邊", "辺")
strName = Replace(strName, "邉", "辺")
strName = Replace(strName, "愼", "慎")
strName = Replace(strName, "將", "将")
strName = Replace(strName, "聰", "聡")
ChangeName = strName
End Function

No.4 ベストアンサー 回答者： WindFaller 回答日時： 2018/05/08 19:43

>他の列にも対応させるには、

でコードを書いていらっしゃいますが、基本的にも考え方も間違っていません。
フリーズの要素は、別にあるのだと思います。それがなんなのかが分かりませんので、あえてジャンプ機能を使って(定数かつ文字列)であるなら、置換を試みる方法でやってみます。範囲の選択は不要です。
　SpecialCells(xlCellTypeConstants, xlTextValues).Cells

'//
Sub Macro2()
Dim c As Variant
Application.ScreenUpdating = False
For Each c In ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues).Cells
　 c.Value = ChangeName(c.Value)
Next c
Application.ScreenUpdating = True
End Sub

もし、これで不具合が出るようですと、ひとつずつエラーになった原因を突き止めなくてはなりません。それと、元のソースが、ネットやWindows系以外のものですと、
ユーザー定義関数に渡す前に、
c.Value = ChangeName(c.Value)
　　↓
c.Value = ChangeName(Application.Clean(c.Value))
と、Clean 関数で、エスケープシーケンス等のバイナリコードを取り去ったほうがよい場合があります。

>「今の規模(100文字程度まで)なら、そのままでよいのですが、異字・旧字置き換え対象候補すべてで、1,400文字×2ぐらいが必要です。」の部分が理解できませんでした。

異字体、旧字の登録されているのが、調べてみると1083個、
元　|旧字・異字
------------
亜　|亞
唖　|啞　瘂
1083 　→それぞれを展開させるので、
↓
上記から置換リストを作ります。（右：検索語, 左：置換語)
亜　|亞　　↓このように展開します。唖　は、2行になります。
唖　|啞
唖　|瘂

ざっと、1400漢字（内ダブリあり)　元の漢字に集約させるために、2行ないし3行にしてやる必要があります。検索語と置換語を併記して2列になります。それは、私にとってはあまりありがたくない話で、それは、今までのユーザー定義関数の方法ではおそらくダメだと思います。それにかなり気が滅入る作業の気がします。というよりも、私の集中力が落ちているせいなのですが。

ただ、私がこういうことに興味を持ったのは、Windowsが出る前のことで、今調べてみると、そんなに大きく変わっていないようです。その際は、前述で書いたようにbregexp.dll または、Basp21 をお薦めすることになります。

この回答へのお礼

詳しく教えていただきありがとうございます。
書いていただいたコードでうまく動きました。

お礼日時：2018/05/09 14:15

No.3 回答者： WindFaller 回答日時： 2018/05/04 18:42

こんにちは。

>一つ目のコードで実行したところ、開いているシートにおける置換はうまくできたのですが、それ以外のシートには動いていないようでした。

簡単にどこでも使えるようにするには、「Personal.xlsb（マクロの記録の時に、『個人用マクロブック』と出てくる場所」の標準モジュールに同じように登録（貼り付け)します。名称は、Sub Macro1 ではなく、Sub 旧漢字変換() とでも分かりやすい名前がよいでしょう。ユーザー定義関数とセットにして貼り付けてください。

ファイル－オプション－クイックアクセスツールバー
で、「個人用マクロブック」で、Subプロシージャ名を選んであげれば、どこでも使えるようになります。「個人用マクロブック」は、プロシージャを貼り付けた時点で、Ctrl + Sで上書きすると、終了時にスムーズに終われます。

そのコード中で、
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
ただ、この部分は、
For Each c In Selection
にして、マウスで選択させるようにすればよいです。

それと、私がこの質問で気にしている部分は、どの程度の規模になるかということです。
確かに、今の規模(100文字程度まで)なら、そのままでよいのですが、異字・旧字置き換え対象候補すべてで、1,400文字×2ぐらいが必要です。

途中までリストは作ってみたものの、もし、そのぐらいの規模になれば、アドインにしなくてはならないことになります。

その場合は、再度、改めてコードを書き直します。（以前、同じような質問で、中途になってしまったものが開発中のままになっています。)

>2つ目のコードはインストールの部分が理解できずに諦めました。
かつては、bregexp.dll 一般のVB系プログラム本にも紹介されている公的なツールとして筆頭に挙げられたものです。Excelで正規表現を本格的に使うようであれば、インストールだけぐらいでしたら教えてさしあげてもよいのですが、ここの掲示板で、それを言っているのは私ぐらいでしかありません。

この回答へのお礼

ありがとうございます。

おっしゃるとおり、「For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))」の部分は1列目でないと動作しないコードですね。
複数の様式の異なるシートにおいて動作させたいため、マウスで範囲選択するのは大変です。

他の列にも対応させるには、
For Each c In Range("C1", Cells(Rows.Count, 3).End(xlUp))
c.Value = ChangeName(c.Value)
Next c
For Each d In Range("G1", Cells(Rows.Count, 7).End(xlUp))
d.Value = ChangeName(d.Value)
Next d
For Each e In Range("B1", Cells(Rows.Count, 2).End(xlUp))
e.Value = ChangeName(e.Value)
Next e
というように追記すればよいのでしょうか？
（これで実行したところ、2回中、2回フリーズしましたが）

また、申し訳ないのですが、「今の規模(100文字程度まで)なら、そのままでよいのですが、異字・旧字置き換え対象候補すべてで、1,400文字×2ぐらいが必要です。」の部分が理解できませんでした。

お礼日時：2018/05/08 18:31

No.2 回答者： WindFaller 回答日時： 2018/04/27 20:06

#1で書いた通り

''標準モジュールに登録／ThisWorkbook モジュールではありません。
注意書きが書かれてもなお、Thisworkbookを使おうというのは、それが癖になっていませんか？

Excelでは、一般的に標準モジュールを使うようになっています。
Excelの表画面から、Alt + F11 -> Alt + I -> m (標準モジュール－挿入)

Excelでは、標準モジュールとそれ以外のオブジェクトモジュール(シート・Thisworkbook, Userform, Class) と別れます。後者は特別なイベント型のマクロを乗せます。Thisworkbook の本格的な使い方は、難易度がかなり高いです。

二つ目も当然、標準モジュールを使いますが、これは、Basp21 というツールをインストールしないと使えません。インストールができないのでしたら、諦めてください。

この回答へのお礼

遅くなってすみません。
ボケていたようで、わざわざ標準モジュールと書いていただいていたのに、失敗していました。
申し訳ありませんでした。

一つ目のコードで実行したところ、開いているシートにおける置換はうまくできたのですが、それ以外のシートには動いていないようでした。
アクティブにしているシートだけではなく、このコードを書いたエクセルファイル全体に対して動かすことは可能ですか？

2つ目のコードはインストールの部分が理解できずに諦めました。

お礼日時：2018/05/04 15:18

No.1 回答者： WindFaller 回答日時： 2018/04/24 20:45

まず、掲示板のマクロコードの修正

''標準モジュールに登録／ThisWorkbook モジュールではありません。
'//
Sub macro1()
Dim c As Variant
Application.ScreenUpdating = False
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
c.Value = ChangeName(c.Value)
Next c
Application.ScreenUpdating = True
End Sub

Function ChangeName(ByVal strName As String) As String
　If strName <> "" Then
　　strName = Replace(strName, Space(1), Space(1), , , vbTextCompare)
　　strName = Replace(strName, "髙", "高")
　　strName = Replace(strName, "邊", "辺")
　　strName = Replace(strName, "邉", "辺")
　　strName = Replace(strName, "愼", "慎")
　　strName = Replace(strName, "將", "将")
　　strName = Replace(strName, "聰", "聡")
　　ChangeName = strName
　End If
End Function
'//

c.Value = Replace(buf1, Space(1), Space(1), , , vbTextCompare)
このコードは、テキストコンペアモードで、スペースを比較して、全角スペースを半角にするというコードです。デフォルトは、バイナリコンペアモードです。

人名漢字で、どの程度、旧漢字や異字体が出現するかにも依存しますが、
実際の表では、Perl やRuby などのほうが良いような気がします。
以前、Perl のExcel アドインがあると聞いたので、ずっと探したのですが、見当たりません。Perl もどきで、以下のような書き方が可能です。

http://www.hi-ho.ne.jp/babaq/basp21.html
2007/06/29版をインストール　または、BREGEXP.DLL　単独をインストール(コードが変わります)このように書くことは可能になります。ただし、全ての旧漢字・異字体をカバーできるとは思えません。

'//
Sub BTranslateTest()
Dim bobj As Object
Dim c As Variant
Dim buf As String, buf1 As Variant　'(Variant のみ)
Dim ret As Long
Set bobj = CreateObject("Basp21")
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
　 buf = c.Value
　ret = bobj.Translate("tr/髙邊邉愼將聰/高辺辺慎将聡/kg", buf, buf1)
　 c.Value = Replace(buf1, Space(1), Space(1), , , vbTextCompare)
Next c
End Sub

この回答へのお礼

ありがとうございます。
しかし、最初に書いていただいたプロシージャをthisworkbookに貼り付けて実行しようとしても、動きませんでした。。

また、２つめのSubプロシージャについても同様に実行しようとしたのですが、動きませんでした。

私の操作が違うのでしょうか。

お礼日時：2018/04/27 17:27