Excel / ExcelVBAメモ

備忘用。

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

### 全シートのセル/オートシェイプの正規表現テキスト検索
work日付時刻シートを末尾に作成し、検索結果をハイパーリンクで一覧表示します。

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

```vb
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
```

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

```vb:変換条件=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
```


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

```vb
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
```

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

```vb
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
```

### 大量の文字入りオートシェイプ作成
```vb
For Each rng In ActiveSheet.Range("A1:A50") : ActiveSheet.Shapes.AddShape( msoShapeRectangle, 100, 100, 180, 40).TextFrame.Characters.Text = rng.Text : Next
```


### 全シート名取得
```vb
For Each sh In Worksheets : debug.print sh.name : Next
```


### 隠しシートを再表示
```vb
For Each sh In Worksheets : sh.Visible = xlSheetVisible : Next
```

### 指数表示されてしまったセルを直す
```vb
For Each rng In ActiveSheet.UsedRange.Columns : rng.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat) : Next
```

### 文字列を数値などに直す
```vb
For Each rng In ActiveSheet.UsedRange.Columns : rng.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlGeneralFormat) : Next
```

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

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

## 16進文字列をASCII文字で返却する
```vb:例：=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文字で返却する
```vb:例：=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
```

## 口座名義カナの入力用？
お遊びで作ったやつ

```vb:例：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高速化テクニック
思いつくものをリストアップ

### 画面描画を止める（高速化）
```vb
Application.ScreenUpdating = False
```

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

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

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

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

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


## 独自カスタム関数
VBA側で定義すると使える。

### 正規表現用(Check)
```vb
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)
```vb:該当項目抽出（ワークシートから関数として呼べるよ）
# 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初期化判定
```vb
Dim var() As Variant
If Not Not var Then
  ' varは初期化済
End If
```

## 配列の結合
```vb
Const dlmt As String = ","
Split(Join(ary1, dlmt) & dlmt & Join(ary2, dlmt), dlmt)
```

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

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

### 見えない名前定義を表示

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

```vb
For Each name In Names : name.Visible = True : Next
```
その後、「数式 > 名前の管理」で、不要な定義を選択して削除

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

### 不要Cellスタイルの削除
ファイル拡張子（xlsx/xlsmなど）をzipに変更して解凍して

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

</div></details>

## UNIX Time から EXCELのシリアル値（日付・時間）に変換
```vb
= (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 とする。
```

## ダイアログによるフォルダ指定
```vb
' フォルダ指定
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        path = .SelectedItems(1)
     Else
        MsgBox "キャンセルします"
        Exit Sub
    End If
End With
```

## 未作成の場合、フォルダ作成
```vb
' フォルダ作成
With CreateObject("Scripting.FileSystemObject")
    If .folderexists(folderspec:=<指定パス>) = False Then
        .createfolder <指定パス>
    End If
End With
```

## ステータスバーに進捗状況を表示
```vb
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に移動）
```vb
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?判定
```vb
If Len( Range("a1").value ) > 0 Then
    MsgBox "test"
End If
```