Excel / ExcelVBAメモ

備忘用。

ワンライナーシリーズ

イミディエイトウィンドウへコピペする。
コードの表示(Alt+F11) -> イミディエイトウィンドウ(Ctrl+G)
VBE仕様：1行最大文字数は1,024文字

全シートのセル/オートシェイプの正規表現テキスト検索

work日付時刻シートを末尾に作成し、検索結果をハイパーリンクで一覧表示します。

グループ化されているとエラーになります。いつか対応予定
ツーライナー
ワンライナーにできる人いたら教えてください

reg=InputBox(Prompt:="検索条件を入力してください。（正規表現可）",Default:="[0-9]{4}"):Set l=CreateObject("System.Collections.ArrayList"):Set r=CreateObject("VBScript.RegExp"):r.Pattern=reg:r.IgnoreCase=False:r.Global=True:d=CHR(0):Application.ScreenUpdating=False:For Each s In Worksheets:For Each g In s.UsedRange:Select Case VarType(g):Case VbError::Case Else:Select Case r.Test(g.value):Case vbTrue:l.Add "'"&s.Name & "'!" & g.Address & d & g.value:End Select:End Select:Next:For Each p In s.Shapes:Select Case p.Type:Case msoGroup:For Each it In p.GroupItems:Select Case it.TextFrame2.HasText:Case vbTrue:Select Case r.Test(it.TextFrame2.TextRange.Text):Case vbTrue:l.Add "'"&s.Name & "'!" & it.TopLeftCell.address & d & it.TextFrame2.TextRange.Text:End Select:End Select:Next:Case Else:Select Case p.TextFrame2.HasText:Case vbTrue:Select Case r.Test(p.TextFrame2.TextRange.Text):Case vbTrue:l.Add "'" & s.Name & "'!" & p.TopLeftCell.address & d & p.TextFrame2.TextRange.Text _
:End Select:End Select:End Select:Next:Next:Worksheets.Add after:=Worksheets(Worksheets.Count):ActiveSheet.Name="work"&Format(now,"yyyymmddhhmmss"):[A2:B2]=[{"アドレス","検索結果文字列"}]:[A1]="検索文字列："& reg:[A1:B1].ColumnWidth=30:For i=0 To l.Count-1:t=Split(l(i),d):ActiveSheet.Hyperlinks.Add Anchor:= Cells(i+3, 1), Address:="",SubAddress:= t(0):Cells(i+3,2).Value=t(1):Next:Application.ScreenUpdating=True:Set l=Nothing:Set r=Nothing

全シートのセル/オートシェイプのテキスト正規表現置換

変換条件=reg,置換条件=repを適宜変更してください

reg = "([0-9]{4})": rep = "#$1#": Application.ScreenUpdating = False: Set r = CreateObject("VBScript.RegExp"): r.Pattern = reg: r.IgnoreCase = False: r.Global = True: For Each sht In Worksheets: For Each rng In sht.UsedRange: Select Case r.Test(rng.Value): Case vbTrue: rng.Value = r.Replace(rng.Value, rep): End Select: Next: For Each shp In sht.Shapes: Select Case shp.Type: Case msoGroup: For Each it In shp.GroupItems: Select Case it.TextFrame2.HasText: Case vbTrue: it.TextFrame2.TextRange.Text = r.Replace(it.TextFrame2.TextRange.Text, rep): End Select: Next: Case Else: Select Case shp.TextFrame2.HasText: Case vbTrue: shp.TextFrame2.TextRange.Text = r.Replace(shp.TextFrame2.TextRange.Text, rep): End Select: End Select: Next: Next: Application.ScreenUpdating = True: Set r = Nothing

アクティブシートのオートシェイプテキスト出力

For Each shp In ActiveSheet.Shapes: Select Case shp.Type: Case msoGroup: For Each it In shp.GroupItems: Select Case it.TextFrame2.HasText: Case vbTrue: Debug.Print it.TextFrame2.TextRange.Text: End Select: Next: Case Else: Select Case shp.TextFrame2.HasText: Case vbTrue: Debug.Print shp.TextFrame2.TextRange.Text: End Select: End Select: Next

アクティブシートのオートシェイプテキストのフォント/フォントサイズの一律変更

font="Meiryo UI": fsize=10: For Each shp In ActiveSheet.Shapes: Select Case shp.Type: Case msoGroup: For Each it In shp.GroupItems: Select Case it.TextFrame2.HasText: Case vbTrue: it.TextFrame2.TextRange.Font.Size = fsize: it.TextFrame2.TextRange.Font.Name = font: it.TextFrame2.TextRange.Font.NameFarEast = font: End Select: Next: Case Else: Select Case shp.TextFrame2.HasText: Case vbTrue: shp.TextFrame2.TextRange.Font.Size = fsize: shp.TextFrame2.TextRange.Font.Name = font: shp.TextFrame2.TextRange.Font.NameFarEast = font: End Select: End Select: Next

大量の文字入りオートシェイプ作成

For Each rng In ActiveSheet.Range("A1:A50") : ActiveSheet.Shapes.AddShape( msoShapeRectangle, 100, 100, 180, 40).TextFrame.Characters.Text = rng.Text : Next

全シート名取得

For Each sh In Worksheets : debug.print sh.name : Next

隠しシートを再表示

For Each sh In Worksheets : sh.Visible = xlSheetVisible : Next

指数表示されてしまったセルを直す

For Each rng In ActiveSheet.UsedRange.Columns : rng.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat) : Next

文字列を数値などに直す

For Each rng In ActiveSheet.UsedRange.Columns : rng.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlGeneralFormat) : Next

Excelに喋らせる

# ヤンデレなExcelさん
Application.Speech.Speak ("私の声、ロボ声に聞こえますか？聞こえませんよねぇえぇ？")

# A1セルの内容を喋らせる
[A1].speak

16進文字列をASCII文字で返却する

例：=hex2chars("3130")→10

Public Function hex2chars(ByVal target As String)
  Dim ret As String
  Dim arr() As String
  Dim cnt As Long
  Dim i As Long
  cnt = (Len(target) + 1) \ 2
  ReDim arr(1 To cnt)
  For i = 1 To cnt
    arr(i) = Mid(target, i * 2 - 1, 2)
  Next i
  For Each m In arr
     ret = ret & Chr(WorksheetFunction.Hex2Dec(m))
  Next
  hex2chars = ret
End Function

16進文字列をSJIS文字で返却する

例：=hex2sjis("8E529363")->山田

Public Function hex2sjis(ByVal str As String)
  If Len(str) Mod 2 <> 0 Then
    hex2sjis = ""
    Exit Function
  End If
  Dim v As Variant: v = splitStr(str, 2)
  Dim tmp() As Byte, i As Long
  ReDim tmp(0 To UBound(v))
  For i = 0 To UBound(v) - 1
    tmp(i) = Val("&H" & v(i))
  Next
  hex2sjis = StrConv(tmp, vbUnicode)
End Function

Private Function splitStr(ByVal str As String, ByVal length As Long) As Variant
  Dim v As Variant, i As Long
  Dim n As Long: n = 0
  ReDim v(0 To Round(Len(str) / length - 0.5, 0))
  For i = 1 To Len(str) Step length
    v(n) = Mid(str, i, length)
    n = n + 1
  Next
  splitStr = v
End Function

口座名義カナの入力用？

お遊びで作ったやつ

例：convKouzaMeigiKana("山田太郎")→ﾔﾏﾀﾞﾀﾛｳに置換

Public Function convKouzaMeigiKana(ByVal target As String)
  ' 日本損害保険協会 準拠
  Dim ret As String: ret = ""
  Dim work As String: work = ""
  Dim tmp As String: tmp = ""
  work = Application.GetPhonetic(target)
  For i = 1 To Len(work)
    tmp = Mid(work, i, 1)
    tmp = Replace(tmp, "ァ", "ア")
    tmp = Replace(tmp, "ィ", "イ")
    tmp = Replace(tmp, "ゥ", "ウ")
    tmp = Replace(tmp, "ェ", "エ")
    tmp = Replace(tmp, "ォ", "オ")
    tmp = Replace(tmp, "ャ", "ヤ")
    tmp = Replace(tmp, "ュ", "ユ")
    tmp = Replace(tmp, "ョ", "ヨ")
    tmp = Replace(tmp, "ッ", "ツ")
    tmp = Replace(tmp, "・", ".")
    tmp = Replace(tmp, "ー", "-")
    ret = ret & tmp
  Next i
  convKouzaMeigiKana = StrConv(ret, vbNarrow)
End Function

VBA高速化テクニック

思いつくものをリストアップ

画面描画を止める（高速化）

Application.ScreenUpdating = False

セル処理を配列格納後にする

ほとんどのケースで実際に使うのはセル中のValueだけ。
なら、それだけを配列で確保して処理した方が速い

Dim ary() As Variant 
ary = Range("A1:E5").Value 
~ 処理 ~
Range("A1:E5").Value = ary 

Excel関数も使う

優良高速な関数もVBA側から積極的に使う

WorksheetFunction.VLookup(Cells(i, 1), Range("D2:E6"), 2, False)

work用worksheetを使う

一時処理用のシートを用意し、処理後に破棄する。

独自カスタム関数

VBA側で定義すると使える。

正規表現用(Check)

Public Function regTest(ByVal reg As String, ByVal target As String)
  With CreateObject("VBScript.RegExp")
    .Pattern = reg
    .IgnoreCase = False
    .Global = True
    If .Test(target) Then
      regTest = True
    Else
      regTest = False
    End If
  End With
End Function

正規表現用(Capturing groups)

該当項目抽出（ワークシートから関数として呼べるよ）

# exam. =regExtract("(cat)","kcat2cat.ThreeCats.")
Public Function regExtract(ByVal reg As String, ByVal target As String)
  Dim matches, str As String
  With CreateObject("VBScript.RegExp")
    .Pattern = reg
    .IgnoreCase = False
    .Global = True
    Set matches = .Execute(target)
    If matches.Count > 0 Then
      For Each m In matches
        For Each sm In m.submatches
          str = str & sm & ","
        Next
      Next
      regExtract = Left(str, Len(str) - 1)
    Else
      regExtract = ""
    End If
  End With
  Set matches = Nothing
End Function

Variant初期化判定

Dim var() As Variant
If Not Not var Then
  ' varは初期化済
End If

配列の結合

Const dlmt As String = ","
Split(Join(ary1, dlmt) & dlmt & Join(ary2, dlmt), dlmt)

Excelの外部リンクや名前定義が残存してる場合

消し方提案

※かなり荒っぽいです Excelファイルの中には、結構様々な個人情報やファイルパスが残存していることがある。 他ユーザのファイルをコピペで作成することが多い為と思われる。

見えない名前定義を表示

Alt + F11を押下して、VBEを起動しそのイミディエイト・ウィンドウに以下をコピペする。

For Each name In Names : name.Visible = True : Next

その後、「数式 > 名前の管理」で、不要な定義を選択して削除

個人情報などの検査

ファイル > 情報 > 問題のチェック > ドキュメント検査
検出されたものを「すべて削除」

不要Cellスタイルの削除

ファイル拡張子（xlsx/xlsmなど）をzipに変更して解凍して

xl/styles.xml

〜（後半のほう）
<cellStyles count="2"><cellStyle name="標準" xfId="0" builtinId="0"/><cellStyle name="〜/></cellStyles>
〜

の部分で不要項目を削除する。
のcountが要素数とリンクしているようだが噛み合わなくても起動はする模様。
※xmlファイルを整形してExcelアプリで読み込ませるとエラーになる模様。
修正後に解凍フォルダ・ファイルをzip圧縮（無圧縮）して、xlsx/xlsmなどExcelアプリで読み込めるファイル拡張子に変更する。

UNIX Time から EXCELのシリアル値（日付・時間）に変換

= (A1 + 9 * 60 * 60) / ( 24 * 60 * 60 ) + 25569

もしくは

=TEXT( (A1 + 9 * 60 * 60) / ( 24 * 60 * 60 ) + 25569, "yyyy/mm/dd(aaa) hh:mm:ss" )

※1 ･･･ 25569 = UNIX Time の基準時刻 (1970/01/01(木) 00:00:00 UTC) に相当するシリアル値

※2 ･･･ 表示形式 ⇒ ユーザー定義 ⇒ yyyy/mm/dd(aaa) hh:mm:ss とする。

ダイアログによるフォルダ指定

' フォルダ指定
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        path = .SelectedItems(1)
     Else
        MsgBox "キャンセルします"
        Exit Sub
    End If
End With

未作成の場合、フォルダ作成

' フォルダ作成
With CreateObject("Scripting.FileSystemObject")
    If .folderexists(folderspec:=<指定パス>) = False Then
        .createfolder <指定パス>
    End If
End With

ステータスバーに進捗状況を表示

Application.StatusBar = String((cnt / all) * 40, "■") & _
  String(40 - (cnt / all) * 40, "□") & " （" & cnt & "/" & all & " 完了）"

' sample (イミディエイトウィンドウにコピペ。セルを書き換えるのでテスト用xlsxで)
cnt = 1 : all = Worksheets.count : _
For Each sh In Worksheets : _
  Application.StatusBar = String((cnt / all) * 40, "■") & _
    String(40 - (cnt / all) * 40, "□") & " （" & cnt & "/" & all & " 完了）" : _
  For i = 1 To 100 : sh.Cells(i + 1, 1).Value = i : sh.Rows(i + 1).Copy : sh.Rows(i).PasteSpecial : Next i : _
  cnt = cnt + 1 : _
Next sh : _
MsgBox "done." : Application.StatusBar = ""

整頓用（ズーム：85%, シートのA1に移動）

Windows(<オープン済ファイル名>).Activate
ActiveWindow.Zoom = 85
Application.Goto Reference:=<sheet>.Range("A1"), Scroll:=True

' イミディエイトウィンドウへコピペするといい感じ、かも
For Each sh In Worksheets: sh.Select : Application.Goto Reference:=sh.Range("A1"), Scroll:=True : _
sh.Cells.Font.Name = "MS Pゴシック" : sh.Cells.Font.Size = 11 : _
sh.PageSetup.Orientation = xlLandscape : sh.PageSetup.Zoom = False : sh.PageSetup.FitToPagesTall = False : _
sh.PageSetup.FitToPagesWide = 1 : sh.ResetAllPageBreaks : ActiveSheet.PageSetup.PrintArea = "$A:$AA" : _
ActiveWindow.View = xlPageBreakPreview : ActiveWindow.Zoom = 85 : Next : _
Worksheets(1).Select

安全なNothing?判定

If Len( Range("a1").value ) > 0 Then
    MsgBox "test"
End If