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

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

フルアドレスからファイル名を取り出す

fulladdress="C:\work\sample.txt"
splt=split(fulladdress,"\")
msgbox splt(ubound(splt))

ある小数点桁の数字を取得

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

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

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

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

ハイパーリンクのリンク先を取得(同じブックの時)

個人的にちょっとハマったのでメモ。

'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

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

cnt=ActiveSheet.Shapes.Count

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

cnt=ActiveSheet.ChartObjects.Count

チャートオブジェクトを画像として保存する

このマクロを実行しているディレクトリに保存します。

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

シート内にあるチャートオブジェクトをグラフタイトルの名前で全て画像化

ちょっと応用。

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

最終行、最終列の取得

こちらのサイトをご参考に。

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のような書き方ができる。

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

テキストファイルを開いて１行ずつ読み込む

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」というフォルダがあり、その中にファイルが入っていると想定します。

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全削除

cells.clear

マクロ高速化対策

'画面の更新を停止
Application.ScreenUpdating = False
'再計算を停止
Application.Calculation = xlCalculationManual

～～～ここに処理～～～

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

DB接続

インストールが必要だったりするものがあるが面倒なので割愛

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)

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