Excelマクロの改良 (数時間の作業⇒1, 2秒に)
Excelマクロの改良 (数時間の作業⇒1, 2秒に)
うだる暑さの中、マクロを改良し、
新しい部分を追加した。
つぎのような、単語クリックで意味が表示される、
そんなリンクを作るためである。
リンク元 [[전화를>ㅈ#JenHoaRyr]] リンク先 +&aname(JenHoaRyr); 전화를 [電話-]を
ここでㅈはページのなまえ。そこのJenHoaRyrという飛び先をさがす。
文中の<전화를>をクリックすると、<전화를 [電話-]を>が表示される。
作業したシートはつぎのものだ。
Aカラムに単語に分けた語が入っている。
マクロで文字ごとに分解して、Bカラムに入れる。
Sub ■1_文字に分解しソートする■latinigo() Worksheets("(1)latinigo").Select '----------------------文字に分解 Let gxis = 1 While Cells(gxis, 1) <> Empty Let gxis = gxis + 1 Wend For tate = 1 To gxis - 1 Let longo = Len(Cells(tate, 1)) For yoko = 1 To longo Let linio = linio + 1 Let Cells(linio, 2) = Mid(Cells(tate, 1), yoko, 1) Next Next
けさまでは、ここまでのここまでのマクロだった。
Bカラムには、確かに分解された文字が全部入るが、
ソートもしていない。
このあと、手動でソートし、重複している文字を取り除く。
ここでよく取りこぼして同じ文字をつい残してしまっていた。
きょうも、手作業で同じ文字を消していたが、
あまりの大量にすっかりいやになり、
マクロを追加してみようと思った。
まずは、ソートを追加。
マクロの自動記録で記録したものをそのまま使う。
'-------------ソートする Columns("B:B").Select ActiveWorkbook.Worksheets("(1)latinigo").sort.SortFields.Clear ActiveWorkbook.Worksheets("(1)latinigo").sort.SortFields.Add Key:=Range("B1") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("(1)latinigo").sort .SetRange Range("B1:B579") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("B1").Select
次に重複した字を消す。
思ったよりも簡単にできてホッとした。
前の字と同じなら、あとの字を消すようにしている。
Let 行数 = Range("b1").CurrentRegion.Rows.Count '-----------------------------重複を消す Let mae = Cells(1, 2) For tate = 2 To 行数 If Cells(tate, 2) = mae Then Let Cells(tate, 2) = Empty Else Let mae = Cells(tate, 2) End If Next
こうしてできたものは、重複が単に消されただけで
その部分が空白セルになって穴ぼこだらけなので、再度ソートする。
マクロは上と同じものを再度記述。
そもそもなんでこんなことをしているかというと
2つの障害があるからだ。
1. QHMでは、飛び先のアドレス指定にハングルが使えない
2. Excelのマクロエディタでハングルを使えない
どちらもユニコードに対応していないからだと思われる。
しかたなく、ハングルに対応するローマ字を作らざるを得なくなっているのだ。
ローマ字を楽に作成するために
いままでCカラムに、すべて手作業でローマ字を入力していた。
(D, Eは未使用)
ところが、時間をかけて入力するのに、
以前作成したローマ字と同じものがたくさんあり、
最終的に重複するものを削るという余計な手間までかかっていた。
これをマクロでやってしまおう。
Y, Zカラムに、前回作ったものをコピーしておく。
もしもBカラムと同じハングルがあれば、
そのローマ字をEカラムに転写する。
'------------------ローマ字をリストから拾い出す Let リスト行数 = Range("y1").CurrentRegion.Rows.Count For tate = 1 To 行数 Let moto = Cells(tate, 2) For sagasi = 1 To リスト行数 If moto = Cells(sagasi, 25) Then Let Cells(tate, 5) = Cells(sagasi, 26) Let sagasi = リスト行数 End If Next Next End Sub
これで、このマクロは完成。
動かすと、以上の全内容が、ものの数秒で完成した。
このあと、Eカラムのローマ字が転写されていなければ
Dカラムにローマ字を入力する。
新しく入れた部分がわかるようにしたのだ。
※実際にはもう一手間かかる。Microsft製品上では
親指シフト入力ができないので、
A~CカラムをOpenOffice Calcにコピペし
そこで入力を行い、終了後Exccelに書きもどす。
Cには式が入れてあり、DとEを合成する。
こうしてCカラムはすべて埋まっていく。
G~Wカラムにはすべて式が入れてあって、
自動的に完成する。
G~Mは、ハングル1字ずつを入れるところ
O~Uは、それぞれローマ字に変えたところ
Wは、そのローマ字を1単語に合成するところ
ローマ字リスト更新
こうしてできあがったら、次回のために、
新したローマ字化したB, Dを、Y, Zに追加しておこう。
回を追うごとに、リストが大きくなり、
手入力がだんだん減っていくことだろう。
a:2640 t:3 y:0