ExcelVBA その他雑多項目

自分用のメモなので、形は整ってないです。

図形オブジェクトの名前を管理する

Excelのバージョンによって大分違うらしい。最近のバージョンはかなり良くなったらしいが

'シート上で図形の楕円を挿入し、左上の名前ボックスで図形名を「円形1」にしてみる

Debug.Print Selection.name  '円形1
'英語の名前になってしまうという情報があるが、修正された?

Selection.name = "円形555"  '図形の名前を変更。名前ボックスでも変更されているはず


'Excelのバージョンによって図形の名前の扱いは違うらしいので、図形を追加したらすぐに名前を付けてしまうのがいい

Dim shape1 As Shape

'楕円の図形を追加してShape変数にSetし、すぐに名前を変更してしまう。間違いの少ないやり方
Set shape1 = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 200, 300)
shape1.name = "OvalXXX"

Debug.Print ActiveSheet.Shapes(1).Name           '図形のインデックス番号で指定。この指定の仕方はやめたほうがいい
Debug.Print ActiveSheet.Shapes("図形1").Name     '図形の名前で指定

'シートから図形の名前を変更するには、名前の定義から指定するか、以下のようなコードで実施するしかないか。名前ボックスからは指定できない
Selection.ShapeRange.Name = "図形111"


'普通に手作業で図形を追加していくと、Excel側で名前を自動的につけるが、命名の法則は不明で把握できない

メッセージボックス関連

MsgBox "OK"  ' 単純なメッセージボックス

MsgBox "aaa", vbOKOnly  ' OKボタンのみ
MsgBox "aaa", vbOKCancel  ' OKボタンとキャンセルボタン
MsgBox "aaa", vbAbortRetryIgnore  ' 中止・再試行・無視ボタン
MsgBox "aaa", vbYesNoCancel   ' はい・いいえ・キャンセルボタン
MsgBox "aaa", vbYesNo   ' はい・いいえボタン
MsgBox "aaa", vbRetryCancel  ' 再試行・キャンセルボタン

MsgBox "中断しますか?", vbYesNo + vbQuestion   ' 「？」のアイコンを表示
MsgBox "データは消えます", vbOKCancel + vbCritical    ' 警告アイコン表示
MsgBox "数値のみ可", vbOKOnly + vbExclamation   ' 「！」のアイコンを表示
MsgBox "参考情報です", vbOKOnly + vbInformation    ' 情報メッセージアイコンを表示

MsgBox "中断しますか?", vbYesNo + vbQuestion, "中断の確認"  ' タイトルの指定

Dim result1 As VbMsgBoxResult  ' メッセージボックスの戻り値の正式な型らしい
Dim result2 As Variant   ' バリアント型でもOK
Dim result3 As Long      ' 数値型でもOK

result3 = MsgBox("続行しますか?", vbYesNo)
If result3 = vbYes Then  ' 「はい」ボタンが押された場合
    MsgBox "処理を続行します"
ElseIf result3 = vbNo Then  ' 「いいえ」ボタンが押された場合
    MsgBox "中断します"
End If

result1 = MsgBox("ファイルを開きますか?", vbOKCancel)
If result1 = vbOK Then  ' 「OK」ボタンが押された場合
    MsgBox "ファイルを開きます"
ElseIf result1 = vbCancel Then  ' 「キャンセル」ボタンが押された場合
    MsgBox "キャンセルされました"
End If
' ※キャンセルボタンのあるメッセージボックスのみ、右上に「×」が表示されるが、これを押すとvbCancel扱いになる

result2 = MsgBox("異常なデータです", vbAbortRetryIgnore)
If result2 = vbAbort Then  ' 「中止」ボタンが押された場合
    MsgBox "中止します"
ElseIf result2 = vbRetry Then  ' 「再試行」ボタンが押された場合
    MsgBox "再試行します"
ElseIf result2 = vbIgnore Then  ' 「無視」ボタンが押された場合
    MsgBox "無視します"
End If

MsgBox "「はい」ボタンがデフォルト", vbYesNo + vbDefaultButton1   ' 第1ボタンをデフォルトに設定
MsgBox "「いいえ」ボタンがデフォルト", vbYesNo + vbDefaultButton2  ' 第2ボタンをデフォルトに設定
MsgBox "「無視」ボタンがデフォルト", vbAbortRetryIgnore + vbDefaultButton3  ' 第3ボタンをデフォルトに設定

MsgBox "1行目のメッセージ" & vbCrLf & "2行目のメッセージ"  ' メッセージボックス内で改行する

入力用ダイアログボックス(InputBox)

Dim str1 As String

str1 = InputBox("文字を入力してください")
If str1 = "" Then
' InputBox関数ではキャンセルボタンを押した場合、空文字が返る
    MsgBox "キャンセルされました"
Else
    MsgBox str1 & " が入力されました"
End If

str1 = Application.InputBox("文字を入力してください")
If str1 = "False" Then
' ApplicationオブジェクトのInputBoxメソッドではキャンセルボタンを押した場合、Falseが返る
' ただし、"False"という文字列を入力した場合も同様になるので、完全ではない
    MsgBox "キャンセルされました"
ElseIf str1 = "" Then
    MsgBox "入力がありません"
Else
    MsgBox str1 & " が入力されました"
End If

Dim var1 As Variant
var1 = Application.InputBox("文字を入力してください")
If VarType(var1) = vbBoolean Then  ' Boolean型の場合は、キャンセルされたと解釈できる
    MsgBox "キャンセルされました"
ElseIf var1 = "" Then
    MsgBox "入力がありません"
Else
    MsgBox var1 & " が入力されました"
End If


str1 = InputBox(Prompt:="何か文字列を入力してください", Default:="文字列", Title:="文字列入力", XPos:=300, YPos:=2000)
' Prompt  メッセージ　Prompt:=は無くてもOK
' Default  デフォルトの文字列　省略可
' Title  タイトル　省略可
' XPos  ダイアログボックスの横位置　かなり小さい単位(twip?)　省略可
' YPos  ダイアログボックスの縦位置　かなり小さい単位(twip?)　省略可
If str1 = "" Then
    MsgBox "キャンセルされました"
Else
    MsgBox str1 & " が入力されました"
End If

入力用ダイアログボックスでセル範囲を指定する

Dim range1 As Range

On Error Resume Next
Application.DisplayAlerts = False
' セル範囲を指定しないでOKボタンを押すと数式の警告メッセージが出るので、その対策

Set range1 = Application.InputBox("セル範囲を指定してください", Type:=8)
' Type:=8 でRangeオブジェクト取得

If Err.Number <> 0 Then  ' キャンセルボタンを押した場合はエラーになってしまう
    MsgBox "キャンセルされました"
    Err.Clear  ' エラーのクリア
Else
    MsgBox range1.Address  ' 指定範囲のアドレスを取得
    range1.Interior.ColorIndex = 3   ' 指定範囲の背景色を変更
    
End If

On Error GoTo 0
Application.DisplayAlerts = True

'  ※範囲指定しないでOKボタンを押すとNothingが返るという話だが、2016では指定しないでOKを押してもダイアログは閉じない

乱数を生成する

Dim i As Long
Dim minNum As Double
Dim maxNum As Double

Randomize   ' 乱数系列を初期化

minNum = 50
maxNum = 100
For i = 1 To 10
  Debug.Print Int((maxNum - minNum + 1) * Rnd + minNum)
  ' 50～100の整数値をランダムで生成  Int((最大値 - 最小値 +1 ) * Rnd + 最小値)
Next i

Debug.Print "--------------------------------------"

minNum = 4.12
maxNum = 12.56
For i = 1 To 10
  Debug.Print (maxNum - minNum) * Rnd + minNum
  ' 12.56～4.12の数値をランダムで生成  (最大値 - 最小値 ) * Rnd + 最小値
Next i

Debug.Print "--------------------------------------"

minNum = -5.515
maxNum = 1.123
For i = 1 To 10
  Debug.Print (maxNum - (minNum)) * Rnd + (minNum)
  ' 1.123～-5.515の数値をランダムで生成
Next i

Debug.Print "--------------------------------------"



' 重複しない1～10の数値を配列に格納
Dim array1(10) As Long
Dim flagArray(10) As Boolean
Dim rndNumber As Long

For i = 0 To 9
  Do
    rndNumber = Int((10 - 1 + 1) * Rnd + 1)
  Loop Until flagArray(rndNumber) = False
  
  array1(i) = rndNumber
  flagArray(rndNumber) = True
Next i

Dim message As String
For i = 0 To 9
  message = message & array1(i) & vbCrLf
Next i
Debug.Print message

ワークシートなどのイベントの有効／無効を切り替える　EnableEvents

Sub aaa()

    Application.EnableEvents = False  ' イベントの発生を無効にする
    
    Worksheets(1).Activate
    ' シートがアクティブになった時のイベントは用意してあるが、発動しない
    
    Application.EnableEvents = True  ' イベントの発生を有効にする
    Worksheets(2).Activate
    ' シートがアクティブになった時のイベントが発動する

End Sub


Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' このブックのシートがアクティブになった時のイベント

    MsgBox Sh.Name  ' アクティブになったシートのシート名

End Sub

アプリケーション関連のイベント

*************   アプリケーション関連のイベント   *******************

Option Explicit

' クラスモジュールのコード(Class1)。アプリケーションのイベントのコードは、クラスモジュール内に記述する

    Public WithEvents App As Application
    ' Application型の変数 "App" の宣言
    

Private Sub App_NewWorkbook(ByVal Wb As Workbook)
' 新しいブックが作成された時のイベント。引数"Wb"は新しく作成されたブック

    MsgBox "新規作成されたブックのブック名は " & Wb.Name

End Sub



Option Explicit

' 標準モジュールのコード
    Dim xClass As New Class1    ' クラスモジュールの変数として宣言

Sub aaa()

    Set xClass.App = Application
    
    ' ※このプロシージャを実行状態にして、エクセルの「ファイル」タブから新規ブックを作成すると、
    ' クラスモジュールのブック新規作成時のイベントが発生する

End Sub



※イベントは多数の種類があるが、あまり使いやすくはないかも。
イベントを有効にするコードは、個人用マクロブックの標準モジュール内に置くのがセオリーらしい

タイトルバーの文字列を変更する

Application.Caption = "自作アプリケーション名"
' Excelのタイトルバーの、右側の文字列を設定

ActiveWindow.Caption = "自作ブック名"
' Excelのタイトルバーの、左側の文字列を設定


Application.Caption = ""
ActiveWindow.Caption = ActiveWorkbook.Name
' これで標準の状態に戻る

ウィンドウの表示位置・サイズを変更する

With ActiveWindow
    .WindowState = xlNormal
    .Top = 100       ' 左上からの縦位置
    .Left = 300      ' 左上からの横位置
    .height = 500    ' ウィンドウの高さ
    .Width = 1000    ' ウィンドウの幅
End With

With Application
    .WindowState = xlNormal
    .Top = 500
    .Left = 600
    .height = 100
    .Width = 300
End With
' Applicationにしたから全ての開いているブックが対象になるわけではなく、アクティブなブックが対象らしい

' ※なんか挙動がおかしい。当てにしないほうがいいかも

文字列データをクリップボードに貼り付ける

Windowsのバージョンによってはうまくいかないこともあるらしい
'参照設定で、Microsoft ActiveX DataObjects 6.* Library  への参照が必要

Dim xMSForms As MSForms.DataObject
Dim str1 As String
Dim arr1() As String
Dim i As Long

Set xMSForms = New MSForms.DataObject
str1 = ""
ReDim Preserve arr1(0)
For i = 0 To 99
  arr1(i) = CStr(i)
  ReDim Preserve arr1(i + 1)
Next i
ReDim Preserve arr1(UBound(arr1) - 1)

For i = 0 To 99
  str1 = str1 & arr1(i) & vbCrLf
Next i

With xMSForms
  .SetText str1     'str1値をDataObjectに格納する
  .PutInClipboard   'DataObjectのデータをクリップボードに格納する
End With

Set xMSForms = Nothing

画面の表示更新を止める ScreenUpdateing

Application.ScreenUpdating = False
' 画面の表示更新を止める。結果的に処理速度が上がる

Application.ScreenUpdating = True
' 画面の表示更新を再開する



' 処理速度の向上のために、以下の設定をすることも検討してもいい
Application.EnableEvents = False                 ' 各種イベントの発生をOFFにする
Application.Calculation = xlCalculationManual    ' シートの計算を手動計算に

' 元に戻すには、以下
Application.EnableEvents = True                   ' 各種イベントの発生をONにする
Application.Calculation = xlCalculationAutomatic  ' シートの計算を自動計算に

処理速度向上のための設定

With Application
    .ScreenUpdating = False    ' 画面の表示更新を止める
    .EnableEvents = False                 ' 各種イベントの発生をOFFにする
    .Calculation = xlCalculationManual    ' シートの計算を手動計算に
    .DisplayAlerts = False     ' 警告の表示を止める
End With

' 元に戻すには、以下
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

ステータスバーにメッセージを表示する

Dim i As Long

For i = 1 To 10000
    Application.StatusBar = "現在処理中です" & i & " / 10000"
    ' ステータスバーにメッセージを表示
Next i

Application.StatusBar = False    ' ステータスバーの状態を元に戻す


Application.ScreenUpdating = False
For i = 1 To 30000
    Application.StatusBar = "現在処理中です" & i & " / 30000"
Next i

Application.StatusBar = False
Application.ScreenUpdating = True

' Application.ScreenUpdating = False にしても、ステータスバーの表示は変化する


' ※処理速度が大分落ちるみたいなので、使わないほうがいいかも

ダイアログボックス等の戻り値をVariant型の変数で受け取り、確実性を高める

Dim var1 As Variant
var1 = Application.InputBox("文字を入力してください")
' ダイアログボックスの戻り値は、Variant型の変数で受け取るのが確実

If VarType(var1) = vbBoolean Then
' Boolean型の場合は、キャンセルされたと解釈できる(False が返っている)
' 文字列型で受け取り、"False"が返ったらキャンセルとしてもいいが、"False"という入力だったりすると同じことになってしまう
' Excelのバージョンによっては、他の種類のダイアログボックスの場合に、戻り値を文字列型の変数で受け取ると問題がある場合があるらしい

  MsgBox "キャンセルされました"
ElseIf var1 = "" Then
  MsgBox "入力がありません"
Else
  MsgBox var1 & " が入力されました"
End If

Escキーを押してもコードの実行が止まらないようにする

Dim i As Long
Dim j As Long
Dim k As Long

Application.EnableCancelKey = xlDisabled
' Escキーを押しても、コードの実行を止めないようにする
' ただし、任意に止めることも出来なくなるので危険もある

For i = 1 To 100000
    For j = 1 To 10000
        k = 10
        k = 20
    Next j
Next i

MsgBox "OK"

Application.EnableCancelKey = xlInterrupt
' Escキーを押して、コードの実行が止まるように戻す

ダイアログボックスのパラメータ値を設定する

Application.Dialogs(xlDialogPrint).Show Arg1:=2, Arg2:=2, Arg3:=4, Arg4:=10
' 「印刷」ダイアログを開き、各パラメータ値を指定する
'　Arg1:=2　印刷範囲：ページ指定
'　Arg2:=2, Arg3:=4　印刷するページ：2P～4P
'　Arg4:=10　印刷部数:10部

' ※全てのパラメータがVBAから指定できるわけではないらしい

ダブルクォーテーションを表示する

MsgBox """ダブルクォーテーションを両端に表示"""

' 一応、「""」とすればダブルクォーテーションを1つ表示できるが・・


MsgBox Chr(34) & "ダブルクォーテーションを両端に表示" & Chr(34)

' 面倒だから、Chr(34)で表示がいいと思う

.Net FrameWork を利用する(サンプルの配列操作だけでも便利かも)

Sub Sample1()

    Dim DataList, myData, i As Long, buf As String
    Set DataList = CreateObject("System.Collections.ArrayList")     ''.NET Frameworkへの参照
    For i = 1 To 5
        DataList.Add Int(Rnd() * 10000)     ''5個の乱数を配列にセットする
    Next i
    DataList.Sort                   ''配列をソートする
    Set myData = DataList.Clone     ''配列の複製を作る
    For i = 0 To myData.count - 1
        buf = buf & myData(i) & vbCrLf
    Next i
    buf = buf & "------" & vbCrLf
    DataList.Reverse                ''配列を逆順にする
    For i = 0 To DataList.count - 1
        buf = buf & DataList(i) & vbCrLf
    Next i
    MsgBox buf
    Set myData = Nothing
    Set DataList = Nothing
    
End Sub

図形を最前面、最背面に移動する

Dim shape1 As Shape
Dim shape2 As Shape

Set shape1 = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 200, 300)
shape1.Name = "Oval1"
Set shape2 = ActiveSheet.Shapes.AddShape(msoShapeOval, 120, 120, 200, 300)
shape2.Name = "Oval2"

shape1.ZOrder msoBringToFront   '最前面へ移動
shape1.ZOrder msoSendToBack     '最背面へ移動

指定の時間になると起動するマクロを作る

Sub aaa()
    Application.OnTime TimeValue("13:00:00"), "TimeTask"
    
    ' このプロシージャ( aaa() )を実行しておき、指定の時間になるとTimeTask()が呼び出される
    ' だたコードを用意しておくだけでは駄目
End Sub

Sub TimeTask()
    MsgBox "13:00:00 になりました"
End Sub

処理を一時停止する　　Sleep Application.Wait

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'宣言部にこの記述が必要


Sub aaa()
  Dim i
  For i = 0 To 5
    Sleep (1000) ' 1000ミリ秒停止
    Debug.Print Now
  Next
End Sub


Sub bbb()
  Debug.Print Now
  Application.Wait (Now + TimeValue("00:00:05")) '現在時刻から5秒後まで停止する
  Debug.Print Now
End Sub

時間がかかる処理を実行する時に、CPUの使用率を抑える

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' WindowsのAPIであるSleepを使用するための宣言

Sub aaa()

    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    For i = 1 To 100000
        For j = 1 To 100000
    '        Next j
    Next i        k = i + j

    ' この100億回ループ実施中のCPU使用率は、25％くらい(自宅のPCなので、かなりハイスペック)
    
    
    
    For i = 1 To 100000
    
        For j = 1 To 100000
            k = i + j
        Next j
        
        Sleep 1   ' 処理を1ミリ秒停止する
    Next i
    
    ' これでiのループ1回ごとに処理を1ミリ秒止めた場合、CPU使用率は1％くらいになる
    ' ただし、10万×1ミリ秒止まるので、100秒余計に時間がかかることになる
    ' 間違ってjのループ内で停止させないように。100億×ミリ秒止まってしまう

End Sub

処理を中断する　DoEvents

Dim stopFlag As Boolean   ' 処理を中断するためのフラグ

Sub XCount()

    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    Application.ScreenUpdating = False
    
    stopFlag = False
    
    For i = 1 To 10000
        For j = 1 To 100
        
            DoEvents  ' 一時的にOSに処理を渡す。
            
            If stopFlag = True Then  ' 中断命令が出た場合
                If MsgBox("中断しますか？", vbYesNo) = vbYes Then
                    MsgBox "中断しました"
                    Exit Sub
                Else
                    stopFlag = False   ' フラグをFalseに戻せば、処理は続行できる
                End If
            End If
        
            k = i + j
            
        Next j
        
    Next i
    
    Application.ScreenUpdating = True
    
    
    ' ※　DoEvents を使うと、かなり処理速度が落ちる。これはたった100万回の処理だが、数十秒かかる。普通なら1秒とかだろう
    
End Sub


Sub XStop()  ' 中断用ボタンを押した時、このプロシージャが実行されるようにしておく

    stopFlag = True

End Sub

処理の最後に出すメッセージボックスが、アクティブウィンドウ以外に出てしまうのを防ぐ

Dim i As Long
Dim j As Long
Dim k As Long

Application.ScreenUpdating = False
Worksheets(1).Activate

j = 0
For i = 1 To 1000000
    k = Int((Rnd() * 100 - 1) + 1)
    If k >= 50 Then
        j = j + k
    Else
        j = j - k
    End If
Next i

Application.ScreenUpdating = True

Application.EnableEvents = False
' イベントの発生を止める。本来はイベントドリブンの処理を止めるもの
Worksheets(2).Activate
Application.EnableEvents = True

MsgBox j
' イベント発生を止める処理を入れないと、アクティブでないウィンドウにメッセージボックスが
' 出てしまうことがある。処理が終わったかどうかわからなくなるので、入れたほうがいい

配列中に指定の文字列が存在するかを調べる

※文字列データの配列のみ有効らしい
Sub aaa()

    Dim array1() As String
    Dim searchArray As Variant  ' Variant型にする
    Dim searchStr As String
    Dim bolFind As Boolean
    Dim i As Long
    
    ReDim Preserve array1(9)
    
    For i = 0 To 9
        array1(i) = CStr(i + 100)
    Next i
    
    
    searchStr = "102"
    searchArray = Filter(array1, searchStr)  ' array1内に"102"が存在するかを調べる
      ' 検索できるのは、文字列型のデータの配列のみ。数値ではFilterでエラーになる

    If UBound(searchArray) <> -1 Then  ' array1内に"102"が存在する場合は、searchArrayにヒットした値が配列に格納される
        MsgBox searchStr & "は存在する"
    Else
        MsgBox searchStr & "は存在しない"
    End If
    
    
    searchStr = "9"
    searchArray = Filter(array1, searchStr)
    
    If UBound(searchArray) <> -1 Then  ' 部分一致でもヒットしてしまうのが問題
        MsgBox searchStr & "は存在する"
    Else
        MsgBox searchStr & "は存在しない"
    End If
    
    
    searchStr = "7"
    searchArray = Filter(array1, searchStr)
    
    If UBound(searchArray) <> -1 Then
    
        bolFind = False
        For i = 0 To UBound(searchArray)
            If searchArray(i) = searchStr Then
            ' 部分一致でもヒットしてしまうので、完全一致するかを全要素で調べる
                bolFind = True
                Exit For
            End If
        Next i
        
        If bolFind = True Then
            MsgBox searchStr & "は存在する"
        Else
            MsgBox searchStr & "は存在しない"
        End If
    Else
        MsgBox searchStr & "は存在しない"
    End If
End Sub

chr関数で、「"」「'」などの特殊記号を表記する(Chr(34)等)

※Replace関数内では、"'" と書いてもシングルクォーテーションとして認識しないことがあるかも

Chr(34)   "
Chr(39)   '  
Chr(13)   \r  vbCr
Chr(10)   \n  vbLf
Chr(9)    \t  vbTab
Chr(13)+Chr(10)   \r\n  vbCrLf

※タブ文字は、Excelでは半角スペースになってしまうらしい

Debug.Print "a" & Chr(34) & "b"
Debug.Print "a" & Chr(39) & "b"
Debug.Print "a" & Chr(10) & "b"
Debug.Print "a" & Chr(13) & "b"
Debug.Print "a" & Chr(9) & "b"
Debug.Print "a" & Chr(13) + Chr(10) & "b"

結果は以下

a"b
a'b
a
b
a
b
a b
a
b