2019年6月10日月曜日

エクセルのシートで、改行された文字データのセルを上手に置換できるVBAのプログラムを書いたのでござる - VBAマクロ(そのほか)

  
最近、社内で使われるプロトコルのマニュアルを、英語に翻訳して疲れました。
プロトコルは通信制御手段とも言われますが、分かったようで分からない言葉。

仮に身近にある道具を使って説明するなら、USBでデータのやり取りでしょう。
USBメモリーを、パソコンに指してデータを移動させるのは、当たり前なんだ。

それで、ソケットを見ると四つの接続端子しかなくて、しかも二つは電源供給。
となると、データ通信はたったの線二本でしか行われていないことになります。

そうなると、この二本でデータを上手く受け流すには、制御ルールが必要なの。
これが通信制御手段で、英語で格好良くプロトコルって言うだけの話なのです。

ユニバーサル・シリアル・バスは頭文字からUSBなんだけど、通信規格の一つ。
コンピュータの内外から、各回路がデータ交換で共通の経路を使うのに必要だ。

コンピュータ用語ですが、有線だろうが無線の5Gだろうが通信は規格が重要。
このコミュニケーションのしきたりがちゃんとできないと、機械は村八分状態。

勤務する会社が扱う製品も、サーバーと通信できなければ、ただのハコ扱いよ。
だから、システム開発をする上で、きちんとプロトコルを理解してもらいます。

お客さんに提供するマニュアルも揃えますが、海外の顧客が出始めてきました。
このため、是が非にでも英語化する必要に迫られたのか、支援を頼まれました。

    
それで、上記のようなマニュアルに訳しましたが、技術用語の繰り返しが多い。
エクセルで作られているので”置換”の操作もできますが、一つ困りごとが発生。

それは、一つのセルの中でAlt+Enterキーで改行したフレーズを書いた時です。
これって、画面上では改行コードが見えないのですが、Chr(10)が含まれます。

そんな時、置換コマンドでも出来るんですが、検索に貼る文字画面が一行だけ。
入力しながらCtrl+Jキーを押すと改行できるけど、文字が見えなくなりました。

特にカナや漢字へ変換が必要な時に、隠れた字句が変換できたのか分からない。
ならば、該当する字句にセルを当てて、置換を呼び出して改行するとします。

やってみたんだけど、改行が二つ以上になると、かなりやりづらいんだよなあ。
つまり、セル内で改行してある文言が素早く置換できたら迅速に仕上がるんだ。

    
なら、VBAでプログラムを作ってみるしかないと思って、挑戦してみましたよ。
何とかできましたが、プログラミングのミソは、配列のアイデアを活用した点。

セル内の、改行コードのChr(10)で区切られる字句を要素の配列に見立てます。
この配列内容が、指定した範囲内で各セルの内容と合致しているか確認します。

もし合致していれば、置換で指定した字区を、該当セルに書き込んで行きます。
そして、置換で指定された字句は一行から四行までに対応するようにしました。

まあ、コードの特長では、ループ処理と条件分岐式(複数)を活用した分けよ。
ループ処理のFor~Nextに、For Each~Nextを使い、他には条件分岐(複数)。

Select Caseですが、置換の字句も改行コードから要素の配列に分解しています。
それから、この要素数で判断し、改行コードを含む字句に再構成して書き込む。

このため、置換されたセルは、元の字句が三行でも、置換で四行にもできます。
まあ、セル一つで改行コードで四行以上にする人もいないと思って止めました。

というわけで、画面を操作するイベントプロシージャまで組み込んでみました。
他に開いたブックのシート画面から、置換したいセルをコピーしておき、貼り付けるセルをダブルクリックしてデータのみを張り付けるアイデアで、書式までコピペしてしまうのを防いでいるのですが、この他、セルを置換する対象になるブックと、このプログラムのブック以上にブックが開かれていると、置換が実行されないなど、それなりに実用性を意識して作ったのでした。
   
★参考までにコード記述:
※ThisWorkbookのコーディング
Private Sub Workbook_Open()

    With Application
        .WindowState = xlNormal   '標準
        .Width = 200
        .Height = 200
    End With
 
'枠線を残す・消す
    ActiveWindow.DisplayGridlines = False 'True
'行列番号を残す・消す
    ActiveWindow.DisplayHeadings = False 'True
'シート見出しの表示 / 非表示
    ActiveWindow.DisplayWorkbookTabs = False 'True
'スクロールバーを残す・消す
    ActiveWindow.DisplayHorizontalScrollBar = False
    ActiveWindow.DisplayVerticalScrollBar = False
 
Cells(3, 2).Value = ""
Cells(3, 4).Value = ""
ActiveCell = Cells(1, 1)
Worksheets(1).Activate

End Sub
-------------------------------------------------------------------------
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal

Target As Range, Cancel As Boolean)
    On Error Resume Next
    If Not Target.Value = "" Then GoTo EndTsk
    If Target.Value = "" Then Target.PasteSpecial xlPasteValues
    Application.CutCopyMode = True
EndTsk:

End Sub
--------------------------------------------------------------------------
※モジュール1のコーディング
Sub Button1_Click()

 Dim Orgnl As Variant
 Dim Trgt As Variant
 Dim Rvsd As Variant
 Dim Cll As Range
 Dim i As Long
 Dim tmp As String

 For i = 1 To Workbooks.Count
  If Workbooks.Count > 2 Then GoTo Finish
  If Not ActiveWorkbook.Name = Workbooks(i).Name Then tmp =

Workbooks(i).Name
 Next i

Orgnl = Split(ActiveSheet.Cells(3, 2).Value, Chr(10))
Rvsd = Split(ActiveSheet.Cells(3, 4).Value, Chr(10))

Workbooks(tmp).Activate

For Each Cll In Range("A1:AQ1000")

If Cll.Value = "" Then GoTo TskEnd

Trgt = Split(Cll.Value, Chr(10))

If Not UBound(Orgnl) = UBound(Trgt) Then GoTo TskEnd

For i = 0 To UBound(Trgt)
If Not Orgnl(i) = Trgt(i) Then GoTo TskEnd
Next i

Select Case UBound(Rvsd)
Case 0
Cll.Value = Rvsd(0)
Case 1
Cll.Value = Rvsd(0) & Chr(10) & Rvsd(1)
Case 2
Cll.Value = Rvsd(0) & Chr(10) & Rvsd(1) & Chr(10) & Rvsd(2)
Case 3
Cll.Value = Rvsd(0) & Chr(10) & Rvsd(1) & Chr(10) & Rvsd(2) & Chr(10) &

Rvsd(3)
End Select

TskEnd:

Next Cll

Finish:

ThisWorkbook.Activate
Cells(3, 2).Value = ""
Cells(3, 4).Value = ""

End Sub



いいねと思ったら、三つポチっとね!
にほんブログ村 スキースノボーブログへにほんブログ村 スキースノボーブログ スキーへにほんブログ村 旅行ブログ 旅日記・旅の思い出へ
にほんブログ村    にほんブログ村      にほんブログ村 



0 件のコメント:

コメントを投稿