VBA Tips集（思いつけば随時更新）

業務でマクロを触ることが多いので、備忘録がてらに書いていきます。
何か思いつけば随時更新していく予定です。

## フルアドレスからファイル名を取り出す
```vb:
fulladdress="C:\work\sample.txt"
splt=split(fulladdress,"\")
msgbox splt(ubound(splt))
```

## ある小数点桁の数字を取得
例えば0.123456789の中の小数点第1位の数字を取得したい場合。
（この例だと「1」を取得したい）

```vb:
num=0.123456789
'小数点一桁
dec_set=1
result = val(Mid(Abs(num - Fix(num)), dec_set + 2, 1))
```

これでも取得できるのですが、
エクセルには桁が多くなると親切にも指数表示にしてくれる~~バグ~~仕様があります。
その場合はformatを使い、無理やり指数表示を解除した状態で取得します。

```vb:
num=0.123456789
'小数点一桁
dec_set=1
result = val(Mid(Format(Abs(num - Fix(num)), "0.0000000000000000"), dec_set + 2, 1))
```

## ハイパーリンクのリンク先を取得(同じブックの時)
個人的にちょっとハマったのでメモ。

```vb:
'Sheet1のA1セルにはSheet2のA1へのリンクがされている
If ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Hyperlinks.Count > 0 Then
    splt = Split(ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Hyperlinks.item(1).SubAddress, "!")
    'リンク先のシート名
    sheetname = splt(0)
    'リンク先のセルアドレス
    celladdress=splt(1)
End If
```

## シート内のオートシェイプの個数を取得する

```vb:
cnt=ActiveSheet.Shapes.Count
```

## シート内のチャートオブジェクトの個数を取得

```vb:
cnt=ActiveSheet.ChartObjects.Count
```

## チャートオブジェクトを画像として保存する
このマクロを実行しているディレクトリに保存します。

```vb:
ActiveSheet.ChartObjects(1).Chart.Export ThisWorkbook.Path & "/test.png"
```

## シート内にあるチャートオブジェクトをグラフタイトルの名前で全て画像化
ちょっと応用。

```vb
For i = 1 To ActiveSheet.ChartObjects.Count
    title = ActiveSheet.ChartObjects(i).Chart.ChartTitle.Text
    ActiveSheet.ChartObjects(i).Chart.Export ThisWorkbook.Path & title & ".png"
Next i
```

## 最終行、最終列の取得
[こちら](http://www.niji.or.jp/home/toru/notes/8.html)のサイトをご参考に。

```vb
MaxRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
MaxCol = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
```

## ファイルを開く
Workbook型の変数を用意し、Setを使ってWorkbooks.Openすることで、
下記の場合```xlsfile.Worksheets(1).cells(1,1).Value```のような書き方ができる。

```vb
Dim xlsfile As Workbook
url="C:\work\test.xlsx"
Set xlsfile = Workbooks.Open(Filename:=url)
```

## テキストファイルを開いて１行ずつ読み込む
```vb
f = FreeFile

file = "text.txt"

If Dir(file) = "" Then
    MsgBox file & "が見つかりません"
    Exit Sub
Else
    Open file For Input As #f
End If

Do Until EOF(f)
    Line Input #f, file_line
    MsgBox file_line
Loop

Close #f
```

## 指定フォルダ内にあるファイルを開いて処理する
今回はマクロのあるExcelファイルと同じ場所に「data」というフォルダがあり、その中にファイルが入っていると想定します。
```vb
Sub main()
    Dim wb As Workbook
    
    Dim path
    path = "./data/"
    
    Dim buf
    buf = Dir(path & "*")
    
    Do While buf <> ""
        Debug.Print buf
        Set wb = Workbooks.Open(Filename:=path & buf)
        wb.Close
        Set wb = Nothing
        buf = Dir()
    Loop
End Sub
```

## 自シートCell全削除
```vb
cells.clear
```

## マクロ高速化対策
```vb
'画面の更新を停止
Application.ScreenUpdating = False
'再計算を停止
Application.Calculation = xlCalculationManual

～～～ここに処理～～～

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
```
## DB接続
インストールが必要だったりするものがあるが面倒なので割愛
```vb
Const DB_HOST As String = "HOST"
Const DB_NAME As String = "NAME"
Const DB_USER As String = "USER"
Const DB_PASS As String = "PASS"
Const DB_PORT As String = "5432"

Dim cnn As Object
Dim rs As Object
Set cnn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cnn.Open "Provider=MSDASQL;Driver=PostgreSQL Unicode;UID=postgres;port=" & DB_PORT & ";Server=" & DB_HOST & ";Database=" & DB_NAME & ";PWD=" & DB_PASS & ";"

Dim sql
sql = "ここにSQLを記述"

rs.Open sql, cnn, adOpenForwardOnly, adLockReadOnly

'列数を取得
Dim cnt
cnt = rs.Fields.Count
Dim i
'取得したデータを1行ずつ追記していく
Do Until rs.EOF
    For i = 0 To cnt - 1
        Cells(rcnt, i + 1).Value = RTrim(rs.Fields(i))
    Next i
    rs.MoveNext
Loop
rs.Close

Set rs = Nothing
Set cnn = Nothing
```

## 連想配列を使って重複しないキーを取得する(Dictionary)
```vb
Dim i
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
    If dict.exists(Cells(i, 1).Value) = False Then
        dict.Add Cells(i, 1).Value, ""
    End If
Next i
```