シート内図形のセルグリッド位置調整 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