VBA：SQL日英相互変換

Gemini先生、すばらしい。今回のマクロのソースを「このコードの取扱説明書を日本語で書いて」の一文を添えて貼り付けたら説明書を書いてくれたし。

で、下準備だ。

マクロ対応ブック(.xlsm)に"DBDIC"というシートを作成し、エンティティ定義書やテーブル項目定義書を基に"DBDIC"というテーブルを作れし。項目名、項目IDは正規化しろし。テーブル名と項目名の対応は管理せずそれぞれ個別の辞書を作っている。

セル範囲はどこでもいいが、３，４，６，７カラムにテーブル英名、テーブル日名、項目英名、項目日名が入った表を作れし。カラム位置や並び順を変えたいならMakeDICマクロを修正しろし。
表を範囲選択し、CTRL+Tを押せば、テーブルが作成される。

[テーブルデザイン]－[テーブル名]を”DBDIC"に変更。

VBAエディタから「メニュー追加」を実行すりゃ準備完了。

別のシートを適当に作成し、仕様書から日本語SQLを張り付けたりSQLコードを貼り付け、セル範囲選択し、右クリックメニューから「SQL日英」「SQL英日」「取り消し線文字排除」を実行しろし。クリップボードに結果が転送される。

※下図、whear->where な。面倒だから直さん。

SQLCONV.BAS

Dim ITMENKN As Object Dim ITMKNEN As Object Dim TBLENKN As Object Dim TBLKNEN As Object Public Sub メニュー追加() Call addRightMenu("SQL日英") Call addRightMenu("SQL英日") Call addRightMenu("取消線文字排除コピー") End Sub Sub メニュー削除索() Call delRightMenu("SQL日英") Call delRightMenu("SQL英日") Call delRightMenu("取消線文字排除コピー") End Sub Public Sub addRightMenu(関数名 As String, Optional sShortcut As String = "") Dim Newb As CommandBarControl For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name = "Cell" Or c.Name = "List Range Popup" Then For i = c.Controls.Count To 1 Step 1 If c.Controls(i).BeginGroup = dalse Then If c.Controls(i).Caption = sShortcut & 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 & Shortcut Then c.Controls(i).Delete End If End If End If End If Next Set Newb = c.Controls.Add() Newb.Caption = sShortcut & 関数名 Newb.OnAction = 関数名 Else For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then If InStr(c.Controls(i).Caption, "書式設定") > 0 Or _ InStr(c.Controls(i).Caption, "図として") > 0 Then End If End If Next End If End If Next End Sub Public Sub delRightMenu(関数名 As String, Optional sShortout As String = "") Dim Newb As CommandBarControl Debug.Print CommandBars.Count For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name "Cell" Or c.Name = "List Range Popup" Then Debug.Print c.NameLocal & " : " & c.Name For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then Debug.Print " " & c.Controls(i).Caption If c.Controls(i).captions = Shortout & 関数名 Then c.Controls(i).Delete End If End If Next End If End If Next End Sub Sub MakeDIC() Dim lo As ListObject Dim T3, T4, T6, T7 As String Set sh = ActiveSheet Sheets("DBDIC").Activate Set ITMENKN = CreateObject("Scripting.Dictionary") Set ITMKNEN = CreateObject("Scripting.Dictionary") Set TBLENKN = CreateObject("Scripting.Dictionary") Set TBLKNEN = CreateObject("Scripting.Dictionary") For Each cel In ActiveSheet.ListObjects("DBDIC").ListRows T3 = LCase(StrConv(cel.Range.Cells(3).Text, vbNarrow)) T4 = StrConv(cel.Range.Cells(4).Text, vbWide) T6 = LCase(StrConv(cel.Range.Cells(6).Text, vbNarrow)) T7 = StrConv(cel.Range.Cells(7).Text, vbWide) If Not (TBLENKN.exists(T3)) Then TBLENKN.Add T3, T4 TBLKNEN.Add T4, T3 End If If Not (ITMENKN.exists(T6)) Then ITMENKN.Add T6, T7 ITMKNEN.Add T7, T6 Debug.Print ITMENKN.Item(T6) End If Next sh.Activate End Sub Public Function GetRealText() Dim cel As Object Dim sep As String For i = 1 To Selection.Cells.Count DoEvents Set cel = Selection.Cells(i) If cel.Column <> Selection.Cells(Selection.Cells.Count).Column Then sep = Chr(9) Else sep = Chr(10) End If If cel.Text <> "" Then If cel.Font.Strikethrough Then Else If cel.Text <> cel.Formula Then GetRealText = GetRealText & cel.Text Else On Error GoTo 10 k = cel.Characters.Count For j = 1 To cel.Characters.Count If cel.Characters(j, 1).Font.Strikethrough Then Else GetRealText = GetRealText & cel.Characters(j, 1).Caption End If Next 20 End If End If End If GetRealText = GetRealText & sep Next Exit Function 10 GetRealText = GetRealText & cel.Text Resume 20 End Function Function RegSch(strTarget As String, strPat As String) As Object Dim Matches Dim ret As String Set RE = CreateObject("VBScript.RegExp") With RE .Pattern = strPat .IgnoreCase = True .Global = False End With Set Matches = RE.Execute(strTarget) If Matches.Count = 0 Then Set RegSch = Nothing Else Set RegSch = Matches(0) End If End Function Public Sub SQL日英() Dim sWord As String Dim result As Object Application.StatusBar = "SQL日英:辞書作成" Call MakeDIC Application.StatusBar = "SQL日英:取消線除外中" src = GetRealText() lineStrs = Split(src, Chr(10)) For Each linestr In lineStrs DoEvents nCount = nCount + 1 Application.StatusBar = "SQL日英:" & nCount sWord = linestr Do Set result = RegSch(sWord, "[^\s\t\.\(\)\(\=\-\+\*\<\>\,　．（）（＝－＋＊＜＞，]+") If result Is Nothing Then outtext = outtext & sWord sWord = "" Else outtext = outtext & Left(sWord, result.firstindex) If TBLKNEN.exists(result.Value) Then outtext = outtext & TBLKNEN(result.Value) Else If ITMKNEN.exists(result.Value) Then outtext = outtext & ITMKNEN(result.Value) Else outtext = outtext & result.Value End If End If sWord = Right(sWord, Len(sWord) - result.Length - result.firstindex) End If Loop While (Len(sWord) > 0) Debug.Print linestr outtext = outtext & Chr(10) Next With CreateObject("Forms.TextBox.1") .MultiLine = True .Text = outtext .SelStart = 0 .SelLength = .TextLength .Copy End With Application.StatusBar = "" End Sub Public Sub SQL英日() Dim sWord As String Dim result As Object Application.StatusBar = "SQL英日:辞書作成" Call MakeDIC Application.StatusBar = "SQL英日:取消線除外中" src = GetRealText() lineStrs = Split(src, Chr(10)) For Each linestr In lineStrs DoEvents nCount = nCount + 1 Application.StatusBar = "SQL英日:" & nCount sWord = linestr Do Set result = RegSch(sWord, "[^\s\t\.\(\)\(\=\-\+\*\<\>\,　．（）（＝－＋＊＜＞，]+") If result Is Nothing Then outtext = outtext & sWord sWord = "" Else outtext = outtext & Left(sWord, result.firstindex) If TBLENKN.exists(LCase(result.Value)) Then outtext = outtext & TBLENKN(LCase(result.Value)) Else If ITMENKN.exists(LCase(result.Value)) Then outtext = outtext & ITMENKN(LCase(result.Value)) Else outtext = outtext & result.Value End If End If sWord = Right(sWord, Len(sWord) - result.Length - result.firstindex) End If Loop While (Len(sWord) > 0) Debug.Print linestr outtext = outtext & Chr(10) Next With CreateObject("Forms.TextBox.1") .MultiLine = True .Text = outtext .SelStart = 0 .SelLength = .TextLength .Copy End With Application.StatusBar = "" End Sub Public Sub 取消線文字排除コピー() Dim outtext As String outtext = GetRealText() With CreateObject("Forms.TextBox.1") .MultiLine = True .Text = outtext .SelStart = 0 .SelLength = .TextLength .Copy End With End Sub

以下、Gemini先生の説明だ。日英と英日を取り違えてるのは御愛嬌だ。

このマクロは、主に以下の機能を提供します。

このコードの取扱説明書 (This code's manual)

このマクロは、主に以下の機能を提供します。

• メニューの追加と削除
  「SQL日英」や「SQL英日」などのメニューを Excel の右クリックメニューに追加したり削除したりできます。
• 辞書の作成
  あらかじめ用意されたシート ("DBDIC") から、日英変換用の辞書を作成します。
• 取消線文字を除外したコピー
  選択範囲のセルにあるテキストをコピーしますが、取り消し線が付いている文字は除外されます。
• SQL文の変換
  「SQL日英」メニューを選択すると、選択範囲の英字を日本語に変換します。逆に「SQL英日」メニューを選択すると、日本語を英字に変換します。変換には、あらかじめ作成した辞書が使用されます。

使い方

1. このコードを VBA エディタに貼り付けます。
2. 必要に応じて、シート "DBDIC" の内容を変更します (日英変換用の辞書データです)。
3. マクロを実行したいセルまたはシート上で、右クリックメニューから追加したメニューを選択します。

注意

• このマクロは、作成されたシート ("DBDIC") を前提としています。このシートの内容を変更したり削除したりすると、マクロが正しく動作しなくなる可能性があります。

ExcelVBA : 全シート内太文字の名前作成

開いているブックの全シート中の太文字のセル位置で、そのテキストで「名前」を作成するマクロだ。

何に使うかってーと、簡易目次だ。
ブック内の任意シートで「CTRL+G」を押せば名前を選択して、そのセルにジャンプしてくれる。
ま、同じ内容の太文字テキストが複数あった場合、あきらめてくれ。
その名前のみ、手動で名前作成すればイイんじゃね？

VBAのつぼ
今回のシート内全セルループは印刷範囲とデータ存在範囲のうち小さい行桁でループをまわしてる。
セルループのテンプレにつかえし。

ループ中、DoEventとStatusBar文字変更は、暴走疑惑を和らげる為だ。

Sub 太文字名前登録() For Each sh In ActiveWorkbook.Sheets sh.Activate DoEvents Application.StatusBar = sh.Name If sh.PageSetup.PrintArea <> "" Then cnt = sh.Range(sh.PageSetup.PrintArea).Cells.Count rp = sh.Range(sh.PageSetup.PrintArea).Cells(cnt).Row cp = sh.Range(sh.PageSetup.PrintArea).Cells(cnt).Column Else rp = 65535 cp = 65535 End If If sh.Cells.SpecialCells(xlLastCell).Row < rp Then rp = sh.Cells.SpecialCells(xlLastCell).Row If sh.Cells.SpecialCells(xlLastCell).Column < cp Then cp = sh.Cells.SpecialCells(xlLastCell).Column For y = 1 To rp For x = 1 To cp If Len(sh.Cells(y, x)) <> 0 Then If sh.Cells(y, x).Font.Bold = True Then sh.Range(Cells(y, x), Cells(y, x + 1)).Select Selection.CreateNames Top:=False, Left:=False, Bottom:=False, Right:=True Application.StatusBar = sh.Name & "(" & y & "," & x & ")" End If End If Next Next Next Application.StatusBar = "" End Sub

シート内図形のセルグリッド位置調整 Excel Macro

Excel方眼紙で図面を書いてるヤシに朗報だ。

複数の選択された図形オブジェクトを近傍点セルグリッドに合わせてくれるマクロだ。
・図形の左上基点グリッド合わせ（サイズ変更なし）
・図形の右下基点グリッド合わせ（サイズ変更なし）
・図形の左右上下すべてのグリッド合わせ（サイズ変更）

上記３つのどれかを選んで位置調整。

調整方向は縦／横／縦横が選べる。コネクタの除外指定もアリ。

ただし、コネクタはExcelのバージョンによって挙動が違うので期待するな。

Macroのつぼ

VBAのウィンドでフォームの追加をしろし。
フォーム名は"AdjustObject"
フォーム内に何のコントロールを貼るかは、上の画面とフォームのInitialロジックを見て
考えてくれ。フォームをロードするエントリ関数は”図位置調整()”。これを呼び出せば動く。

化石言語BASIC固有の文法で、EndiFを書かないIf文や行番号ジャンプが書かれている。
また、"If CONTROL Then ･･･"は、"If CONTROL.value = True Then･･･"と同じだ。
両方ともコードをシンプルにする為に、ベストな方法だ。
goto文は必要な箇所に充分つかえし。

AdjustObject（コード）

Private Sub UserForm_Initialize() CheckTopLeft = True CheckBottomRight = True OptionX = False OptionY = False OptionYX = True End Sub Private Sub CommandExec_Click() Dim YX As Integer Dim nMode As Integer Dim bAboidConnect As Boolean If OptionX Then YX = 2 If OptionY Then YX = 1 If OptionYX Then YX = 3 nMode = 0 If CheckTopLeft Then nMode = 1 If CheckBottomRight Then nMode = nMode + 2 If CheckConnect Then bAboidConnect = True Else bAboidConnect = False End If Call AdjustOBJ(YX, nMode, bAboidConnect) End Sub

標準モジュール
Sub 図位置調整() AdjustObject.Show End Sub Sub AdjustOBJ(YX As Integer, nMode As Integer, bAboidConnect As Boolean) Dim p1, p2 As Object Dim yy, xx As Double If nMode = 0 Then Exit Sub If TypeName(Selection) = "Range" Then Exit Sub For i = 1 To Selection.ShapeRange.Count With Selection.ShapeRange(i) If InStr(.Name, "Comment") > 0 Then GoTo 100 If InStr(.Name, "onnect") > 0 And bAboidConnect Then GoTo 100 Set p1 = GetNearCell(.Top, .Left, .TopLeftCell) Set p2 = GetNearCell(.Top + .Height, .Left + .Width, .BottomRightCell) If nMode = 1 Then If YX = 1 Or YX = 3 Then .Top = p1.Top If YX = 2 Or YX = 3 Then .Left = p1.Left ElseIf nMode = 2 Then If YX = 1 Or YX = 3 Then .Top = p2.Top - .Height If YX = 2 Or YX = 3 Then .Left = p2.Left - .Width Else If YX = 1 Or YX = 3 Then .Top = p1.Top: .Height = p2.Top - p1.Top If YX = 2 Or YX = 3 Then .Left = p1.Left: .Width = p2.Left - p1.Left End If 100 End With Next End Sub Function GetNearCell(y As Double, x As Double, ByRef tg As Object) As Object Set p = ActiveSheet.Cells(tg.Row + 1, tg.Column + 1) If (y - tg.Top) > (p.Top - y) Then If (x - tg.Left) > (p.Left - x) Then Set GetNearCell = p Else Set GetNearCell = ActiveSheet.Cells(p.Row, tg.Column) End If Else If (x - tg.Left) > (p.Left - x) Then Set GetNearCell = ActiveSheet.Cells(tg.Row, p.Column) Else Set GetNearCell = tg End If End If End Function

正規表現検索ワークシート関数 excel macro

クソみたいなexcelのfind関数の代わりにつかってくれ。
他マクロからの呼び出しやワークシート関数として使える。

ただし、検索できるのはソース文字列（orセル）中で最初にマッチした１件のみ。複数検索したいヤシは、For Eachループ内のmatchオブジェクトをナンとかしてくれ。ワークシート関数の体をなしたままだと何かとメンドーそーだ。

使い方

=RegExp(<検索対象>,<正規表現パターン>,<"S" or "P" or "L">)

ex.
=RegExp(C4,"「.*」","S")
   C4セルの中からかぎ括弧で囲まれた文字列を探す。

=RegExp("日月火水木金土",C4,"P")
　C4セルに書かれた文字を曜日並びから検索し、何個目の曜日なのか、文字位置を返す。

=RegExp(C4,"(YES|NO)","L")
 C4セルに書かれた文字が"YES"なら"３"、"NO"なら"２"のようにマッチした文字数を返す。

Macroのつぼ

WSH等で使われるComモジュールのRegExpをEｘcelから呼び出している。
残念な事に、"L","P"を指定したときに返ってくる数値は文字型だ。

まっとうに使いたいヤシは、改造して、直接マクロから呼びだすべし。
マクロ作るのメンドーで、ワークシート関数でナントカしたいヤシ、そのまま使ってくれ。アドイン(.xla)で作った方がイイと思う。

Function RegExp(strTarget As String, strPat As String, para As String) As String Dim Match, Matches Dim ret As String Set RE = CreateObject("VBScript.RegExp") With RE .Pattern = strPat .IgnoreCase = True .Global = False End With Set Matches = RE.Execute(strTarget) For Each Match In Matches RegExp = "" ret = Match.Value For i = 1 To Len(para) Select Case Mid(para, i, 1) Case "P" RegExp = RegExp & Match.FirstIndex + 1 & " " Case "L" RegExp = RegExp & Len(ret) & " " End Select Next If (InStr(1, para, "S") > 0) Then RegExp = RegExp & ret Next End Function

Excel全シートテキスト保存 Excel macro

番外編で Excel Macro VBAだ。

用語辞書作成支援で紹介したAwkScriptだが、食わせる元文書がExcelだと大変。
数十もあるシートをテキスト保存して、Mecabに食わせるなんてウンサリするぞ、
…てなわけで、VBAだ。
ブック名＋シート名.tsvというファイル群を一気に生成する。

ただし、内部的には、保存時にブック名と形式がテキストファイルに変わっているから、最後に戻す、、、と言いたい所だが、ブック名と形式を戻す為には、再度保存しないと戻せない。
勝手に元ブックに保存するのはマズいので、元ブック名の先頭に "_" をつけてみる。

ま、後は好きにやってくれ。

WinMergeのExcelアドインはヘボいから、コイツでテキスト保存して、フォルダ単位にWinMerge差分を採る…なんて使い方もあるぞ。
ただし、オブジェクトは無視してるから我慢してくれ。

Sub 全シートTSV保存() Dim sh As String Dim shn As String Dim bkn As String Dim bknOrg As String okstr = "／〈〉゛｜￤〈〉゛゛゛゛〈〉〈〉" bknOrg = ActiveWorkbook.Name bkn = StrConv(ActiveWorkbook.Name, vbLowerCase) ff = ActiveWorkbook.FileFormat i = InStr(bkn, ".xls") If i > 0 Then bkn = Left(bkn, i - 1) End If For i = 1 To ActiveWorkbook.Sheets.Count shn = ActiveWorkbook.Sheets(i).Name sh = bkn + "_" + shn + ".tsv" For j = 1 To Len(sh) n = InStr("/<>""|;＜＞""""〝〝()（）", Mid(sh, j, 1)) If (n > 0) Then Mid(sh, j, 1) = Mid(okstr, n, 1) End If Next ActiveWorkbook.Sheets(i).Activate ActiveWorkbook.SaveAs Filename:=sh, FileFormat:=xlText, CreateBackup:=False ActiveWorkbook.Sheets(i).Name = shn Next ActiveWorkbook.SaveAs Filename:="_" + bknOrg, FileFormat:=ff, CreateBackup:=False End Sub