忘れがちなVBA

■ 変数宣言の強制化 : Option Explicit

Option Explicit 

■ 画面の更新停止

Application.ScreenUpdating = False

■ プロシージャ

Sub main()
    Application.ScreenUpdating = False
    Call MessageStart
    MsgBox Output1 & Output2("World")
    Call MessageEnd("End")
End Sub

' Subプロシージャ
Sub MessageStart()
    MsgBox "Start"
End Sub

' Subプロシージャ(引数あり)
Sub MessageEnd(Message As String)
    MsgBox "End"
End Sub

' Functionプロシージャ
Function Output1() As String
    Output1 = "Hello "
End Function

' Functionプロシージャ(引数あり)
Function Output2(Message As String) As String
    Output2 = Message
End Function

■ 変数定義

Public Dim a As Type          ' 他のモジュールで使用可能
Dim b As Type                 ' 同一モジュールで使用可能

Sub main()
    static Dim c As Type      ' 静的変数
    Dim d As Type             ' 同一プロシージャで使用可能
    const Dim e As Type = 10  ' 変更不可
    Dim array(2) As Type      ' 配列
    Dim arrayVarLen As Variant' 可変長配列

    array(1) = "one"
    array(2) = "two"
    arrayVarLen = {"one", "two"}

End Sub

Type	Name
Variant	バリアント型
Byte	バイト型
Boolean	ブール型
String	文字列型
Integer	整数型
Long	長整数型
Single	単精度浮動小数点型
Double	倍精度浮動小数点型
Date	日付型
Currency	通貨型
Object	オブジェクト型

■ 型変換

Dim a As String
Dim b As String

Cells(1, 1) = CInt(a) + CInt(b)

変換関数	変換先
CStr	String型
CInt	Integer型
CLng	Long型

■ 文字列操作

左側抜き出し : left

MsgBox Left(Range("A1"), 1)

中央抜き出し : mid

MsgBox Mid(Range("A1"), 2, 3)

右側抜き出し : right

MsgBox Right(Range("A1"), 1)

置換

MsgBox Replace("100 points", " points", "") '100

結合

Dim cnt As Integer
For cnt = 1 To 100 Step 1
  Range("A" & cnt) = cnt
  Range("B" + cnt) = cnt
Next

一致判定

if InStr(String1, String2) <> 0 Then
  MsgBox "match between two Strings"
Else
  MsgBox "mismatch between two Strings"
End If

■ メッセージ入力 : InputBox

Dim message As String
message = InputBox("メッセージを入力してください")

■ メッセージ出力 : MsgBox

メッセージのみ出力

MsgBox "Output Message"

Yes/Noの選択

If MsgBox("Output Messag", vbYesNo) = vbYes Then
    ' Yesの処理
Else
    ' Noの処理
End If

OK/Cancelの選択

If MsgBox("Output Messag", vbOKCancel) = vbOK Then
    ' OKの処理
End If

■ 警告／確認メッセージ非表示

Application.DisplayAlerts = False

■ 条件分岐／ループ

条件分岐 : if

If cnt > 1 Then
    Msgbox "カウントは1より大きい"
Else
    Msgbox "カウントは1以下"
End If

【比較演算子】
A = B ：AとBが等しい場合、真
A <> B ：AとBが等しくない場合、真
A < B ：AがBより小さい場合、真
A <= B ：AがB以下の場合、真
A > B ：AがBより大きい場合、真
A >= B ：AがB以上の場合、真

条件分岐 : select case

Select Case cnt
Case 1
    Msgbox "カウントは1"
Case 2 To 4
    Msgbox "カウントは2から4"
Case Else
    Msgbox "それ以外"
End Select

ループ : for next

Dim cnt
For cnt = 1 To 10 Step 1
    Msgbox cnt
Next cnt

ループ : do loop

Dim cnt As Integer
cnt = 1
Do While Cells(1, cnt) = 0
    MsgBox cnt
    cnt = cnt + 1
    If cnt > 100 Then
        Exit Do
    End If
Loop

■ セル操作

セルの選択

Range("A1").Select
Cells(2, 1).Select

セルの値取得

Dim cnt1 As Integer
Dim cnt2 As Integer

cnt1 = Range("A1")
cnt2 = Cells(2, 1)

セルに値設定

Range("A1") = 100
Cells(2, 1) = "Hello"

セルの値コピー

Cells(1,1).Copy Destination:=Cells(1,2)

複数セルの値コピー

Range("C1:C30").Value = Range("D1:D30").Value

複数セルのクリア

Range("B6:D15").ClearContents
Range(Cells(6, 2), Cells(15, 4)).ClearContents

行の削除

Rows("1").Delete
Rows("1:10").Delete

行の挿入

Rows("2:3").Insert

列の削除

Columns("A").Delete
Columns("A:D").Delete

列の挿入

Columns("B:D").Insert

罫線を引く

Range("A1:B2").Borders.LineStyle = xlContinuous

別シートのセル設定

Sheets("Sheet2").Select
Range("A1") = 1000

■ シート操作

アクティブ設定

Sheets("Sheets Name").Activate

アクティブ設定(存在有無を戻り値で返却)

Private Function activateSheet(sheetName As String) As Boolean
    On Error Resume Next
    Err.Clear

    Sheets(sheetName).Activate

    If Err.Number > 0 Then
        activateSheet = False
    Else
        activateSheet = True
    End If

    On Error GoTo 0
End Function

シート名変更

ActiveSheet.Name = "test1"
Sheets("Sheets Name") = "test2"

シートコピー

Sheets("Sheets Name").Copy Before:=Sheets(Sheets.Count)  '最後尾にシートコピー
Sheets("Sheets Name").Copy Before:=Sheets(Sheets.Count)  '最後尾の一つ前にシートコピー

■ 日付操作

現在時刻設定

Range("A1") = Date '2018/1/1
Range("A1") = Now  '2018/1/1 0:00:00
Range("A1") = Time '0:00:00

■ グラフ操作

範囲変更(縦項目とデータが離れている場合)

Dim start As Variant
Dim end As Variant
start = "C"
finish = "F"
ActiveSheet.ChartObject("Graph Name").Active
ActiveChart.SetSourceData Union(Range("A1:A4"), Range(start & 1,finish & 4))

範囲変更(縦・横項目とデータが離れている場合)

Dim start As Variant
Dim end As Variant
start = "C"
finish = "F"
ActiveSheet.ChartObject("Graph Name").Active
ActiveChart.SetSourceData Union(Range("A1"), Range(start & 1, finith & 1), Range("A7:A10"), Range(start & 7, finish & 10))

幅変更

ActiveSheet.ChartObjects("Graph Name").Width = 1500

■ ワークシート操作

追加

Worksheets.Add

任意位置へ追加

Worksheets.Add Before:=Sheets("Sheet1")

Worksheets.Add After:=Sheets("Sheet1")

削除

ActiveSheet.Delete

■ ブック操作

オープン

Workbooks.Open Filename:="C:\test.xlsm"

新規オープン

Workbooks.Add

クローズ(保存なし)

Workbooks("test.xlsm").Close SaveChanges:=False

クローズ(保存あり)

Workbooks("test.xlsm").Close SaveChanges:=True

■ ファイル操作

フォルダ作成

Mkdir "C:\temp"

フォルダ削除

RmDir "C:\temp"

フォルダ移動

Name ""C:\temp" As "C:\temp\works"

フォルダ名変更

Name "C:\temp" As "C:\works"

■ ハイパーリンク操作

指定セルのハイパーリンク実行

Range("A5").Hyperlinks(1).Follow

選択中セルのハイパーリンク実行

Cells(1, 5).Select
Selection.Hyperlinks(1).Follow

指定範囲中でのハイパーリンク実行

Range(Cells(1, 5), Cells(1, 10)).Hyperlinks(1).Follow

指定セルのハイパーリンクのアドレス取得

Range("A5").Hyperlinks(1).Address

■ エラー

エラーを無視

On Error Resume Next

エラー種別取得

On Error Resume Next
Sheets("Sample").Activate
If Err.Number > 0 Then
    MsgBox "異常"
Else
    MsgBox "正常"
End If

エラー情報無効化

Err.Clear

エラー対応の終了

On Error GoTo 0

エラー発生後ラベルへジャンプ

On Error GoTo errorEnd
'処理
errorEnd:

ユーザ定義のエラー発生

errNum = ActiveCell.Value
Select Case errNum
  Case CVErr(XlErrNull)
    ' error handling operations for #NULL!(2000)
  Case CVErr(xlErrDiv0)
    ' error handling operations for #NULL!(2007)
  Case CVErr(xlErrName)
    ' error handling operations for #NAME?(2029)
  Case CVErr(XlErrNA)
    ' error handling operations for #N/A(2042)
End Select

■ Sleep

API宣言

32bit

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

64bit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)

Sleep実行

sleep 1000 '1秒スリープ

■ withステートメント

With ActiveSheet.Range("A1")
    .Value = "test"
    .Font.Color = RGB(255, 0, 255)
End With

■ コメント

' comment

▽▽▽▽ IE操作編 ▽▽▽▽

■ 参照設定

InternetExplorer型追加

VBE起動 → ツール → 参照設定 → Microsoft Internet Controlsをチェック → OK

■ IE操作

IE起動 & WEBページ移動 & IE終了

Dim ie As InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate "任意のURL"

'### WEBページへアクセス完了待ち処理(略) ###

Dim htmlDoc As HTMLDocument
Set htmlDoc = ie.document

ie.Quit

前のページへ移動

Dim ie As InternetExplorer
'###  ieアクセス処理(略) ###
ie.GoBack

■ textareaタグ操作

id/name属性で検索 & 値を入力

Dim textAreaElem As HTMLTextAreaElement

Set textAreaElem = htmlDoc.getElementById("SearchWord")
textAreaElem.Value = "InputData"

Set textAreaElem = htmlDoc.getElementByName("SearchWord")(1) 'name属性はIndex#指定要
textAreaElem.Value = "InputData"

■ inputタグ操作

name属性で検索 & クリック

Dim inputElem As HTMLInputElement

Set inputElem = htmlDoc.getElementsByClassName("SearchWord")(1)
inputElem.Click
'### WEBページへアクセス完了待ち処理(略) ###

tag名とsrc属性で検索 & クリック

Dim inputElem As HTMLInputElement

For Each inputElem In htmlDoc.getElementsByTagName("INPUT")
    If InStr(inputElem.src, "SearchFile.png") > 0 Then
        inputElem.Click
        '### WEBページへアクセス完了待ち処理(略) ###
        Exit For
    End If
Next

tag名とvalueプロパティで検索 & クリック

Dim inputElem As HTMLInputElement

For Each inputElem In htmlDoc.getElementsByTagName("INPUT")
    If InStr(inputElem.Value, "SearchWord") > 0 Then
        inputElem.Click
        '### WEBページへアクセス完了待ち処理(略) ###
        Exit For
    End If
Next

■ imgタグ操作

tag名とsrc属性で検索 & alt取得 & クリック

Dim htmlImg As HTMLImg

For Each htmlImg In htmlDoc.getElementsByTagName("IMG")
    If InStr(htmlImg.src, "SearchFile.png") > 0 Then
        Cells(1, 1) = htmlImg.alt
        htmlImg.Click
        '### WEBページへアクセス完了待ち処理(略) ###
        Exit For
    End If
Next

■ anchorタグ操作

id属性で検索 & クリック

Dim anchorElem As HTMLAnchorElement

Set anchorElem = htmlDoc.getElementById("SearchWord")
anchorElem.Click
'### WEBページへアクセス完了待ち処理(略) ###

Tag名とinnerTextプロパティで検索 & クリック

Dim anchorElem As HTMLAnchorElement

For Each anchorElem In htmlDoc.getElementsByTagName("A")
    If InStr(anchorElem.innerText, "SearchWord") > 0 Then
        anchorElem.Click
        '### WEBページへアクセス完了待ち処理(略) ###
        Exit For
    End If
Next

■ divタグ操作

クラス名で検索 & 値取得

Dim divElem As HTMLDivElement
Dim text As String

For Each divElem In htmlDoc.getElementsByClassName("SearchWord")
  text = divElem.innerText
  Exit For
Next

クラス名で検索 & divタグ内の最初のanchorタグをクリック

Dim divElem As HTMLDivElement

For Each divElem In htmlDoc.getElementsByClassName("SearchWord")
  divElem.getElementsByTagName("A")(0).Click
  '### WEBページへアクセス完了待ち処理(略) ###
  Exit For
Next

■ tableタグ操作

TH名で検索 & TDタグ取得

Dim cnt As Integer

For cnt = 0 To htmlDoc.all.Length - 1
   If htmlDoc.all(cnt).tagName = "TH" Then
       If htmlDoc.all(cnt).innerText = "SearchWord" Then
           AppActivate Application.Caption
           Cells(1, 1) = htmlDoc.all(cnt + 1).innerText
           Exit For
       End If
   End If
Next cnt

TDタグで検索 & TDタグ内の最初のimageタグのsrc名を取得

Dim cnt As Integer

For cnt = 0 To htmlDoc.all.Length - 1
    If htmlDoc.all(cnt).tagName = "TD" Then
        Cells(1, 1) = htmlDoc.all(cnt).getElementsByTagName("IMG")(0).src
        Exit For
    End If
Next cnt

■ VBSからVBAマクロ起動

Dim searchName
Dim searchExtension
Dim objExcel
Dim objPath
Dim objFso
Dim file
Dim IngPos
Dim Book0
Dim excelbook
Dim xlsxName


searchName = “searchword”
searchExtension = “csv”
Set objExcel = CreateObject(“Excel.Application”)
Set objPath = CreateObject(“Scripting.FileSystemObject”).GetFolder(“.”)
Set objFso = CreateObject(“Scripting.FileSystemObject”)

objExcel.Visible = False
ObjExcel.DisplayAlerts = False

objExcel.Workbooks.Open objPath & macro_templete.xlsm

For Each file In objPath.Files
  IngPos = Instr(file.Name, searchName)
  If IngPos > 0 Then
    IngPos = Instr(file.Name, searchExtension)

    If IngPos > 0 Then
      Set excelbook = objExcel.Workbooks.Open(objPath & “\” & file.name, 1)
      xlsxName = ojbFso.GetBaseName(objPath & “\” & file.name) & “xlsx”
      excelbook.SaveAs objPath & “\” & xlsxName, 51
      objExcel.Run “‘” & objPath & “\macro_template.xlsm” & “‘!format_macro”
    Else
    End If
  Else
  End If
Next

WScript.sleep(1000)

For Each Book0 in objExcel.workbooks
  If Book0.saved = vbfalse Then Book0.save
  Book0.close
Next

objExcel.Quit
Set objExcel = Nothing

WScript.Quit