VBAプロシージャ集

なぜVBAなのか？

• 開発環境構築が楽（Excelが入っていればOK）
• 導入できるソフトウェアに制限がある

ソースコード

mylib.bas

Option Explicit

'-------------------------------------------------------------------------------
'  指定時間プログラムを停止する。
'-------------------------------------------------------------------------------
'  note      : ミリ秒で指定。WindowsAPI。
'-------------------------------------------------------------------------------
Public Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)


'-------------------------------------------------------------------------------
'  列名から列位置を取得する。
'-------------------------------------------------------------------------------
'  param     : aTargetSheet
'  param     : aColumnName  列名
'  param     : aRowIndexOfClomunName  列名が存在する行の位置
'  return    : 列名が存在する列の位置
'-------------------------------------------------------------------------------
Public Function GetColIndex(pTargetSheet As Worksheet, aColumnName As String, Optional pRowIndexOfClomunName As Long = 0) As String
    GetColIndex = WorksheetFunction.Match(pColumnName, pTargetSheet.rows(pRowIndexOfClomunName), 0)  '0:完全一致
End Function


'-------------------------------------------------------------------------------
'  文字列配列を検索し位置を返す。
'-------------------------------------------------------------------------------
'  param     : pArray        文字列配列
'  param     : searchString  検索文字列
'  return    : 文字列配列の位置。検索にヒットしない場合は-1を返す。
'-------------------------------------------------------------------------------
Public Function IndexOf(pArray As Variant, searchString As String) As Long
    Dim i As Long
    For i = 0 To UBound(pArray)
        If pArray(i) = searchString Then
            IndexOf = i
            Exit Function
        End If
    Next
    IndexOf = -1
End Function


'-------------------------------------------------------------------------------
'  コマンド（～.exe）を実行する。
'  またはファイルに関連付けられたアプリケーションを起動する
'-------------------------------------------------------------------------------
'  param     : pCommand       コマンドまたはファイルパス
'  param     : pWindowStyle   0:ウィンドウ非表示
'                             1:通常ウィンドウ
'  param     : pIsSync        false:非同期
'                             true :同期
'  return    : 実行結果
'  note      : vbs対応のため、型定義なし
'-------------------------------------------------------------------------------
Public Function ExecCommand( _
    pCommand, _
    pWindowStyle, _
    pIsSync As Boolean)
    
    Dim wss
    Set wss = CreateObject("WScript.Shell")
    ExecCommand = wss.Run(pCommand, pWindowStyle, pIsSync)
End Function


'-------------------------------------------------------------------------------
'  多階層フォルダ作成（複数階層フォルダ作成）
'-------------------------------------------------------------------------------
'  param      : pFolderPath フォルダパス
'  return     :
'  note       : d:\tempというフォルダ構成に対して
'               d:\temp\first\secondというフォルダを作成できる
'               一般的なフォルダ作成はfirstフォルダが存在していない場合エラー
'               vbs対応のため、型定義なし
'  dependence : ExecCommand
'-------------------------------------------------------------------------------
Public Sub MakeFolder(pFolderPath)
    Call ExecCommand("cmd /c MD " & pFolderPath, 0, True)
End Sub


'-------------------------------------------------------------------------------
'  フォルダパス文字列を結合する
'-------------------------------------------------------------------------------
'  param     : aFolderPath フォルダパス
'  return    :
'  note      : JF("d:\tmp", "backup") ⇒ d:\tmp\backup
'-------------------------------------------------------------------------------
Public Function JF(ParamArray pFolderPathArray() As Variant) As String
    Dim path As String
    Dim folderPath As Variant
    For Each folderPath In pFolderPathArray
        path = path & FormatFolderPath(CStr(folderPath))
    Next
    JF = path
End Function


'-------------------------------------------------------------------------------
'  フォルダパス文字列の書式修正
'-------------------------------------------------------------------------------
'  param     : pFolderPath フォルダパス文字列
'  return    :
'  note      :
'                FormatFolderPath("c:\dummy")  → c:\dummy
'                FormatFolderPath("c:\dummy\") → c:\dummy
'                FormatFolderPath("subdir")    → \subdir
'                FormatFolderPath("\subdir\")  → \subdir
'                FormatFolderPath("\\nethoge\duumy")→ \\nethoge\dummy
'                FormatFolderPath("\\nethoge\duumy\")→ \\nethoge\dummy
'-------------------------------------------------------------------------------
Private Function FormatFolderPath( _
    pFolderPath As String)
    
    Dim folderPath
    folderPath = pFolderPath
    
    '先頭に対する処理
    If Mid(folderPath, 1, 2) = "\\" Or Mid(folderPath, 2, 1) = ":" Then
        '処理なし
    ElseIf Mid(folderPath, 1, 1) <> "\" Then
        folderPath = "\" & folderPath
    End If

    '末尾に対する処理
    If Right(folderPath, 1) = "\" Then
        folderPath = Mid(folderPath, 1, Len(folderPath) - 1)
    End If
    
    FormatFolderPath = folderPath
End Function


'-------------------------------------------------------------------------------
'  エクスプローラーを開く
'-------------------------------------------------------------------------------
'  param      : pFolderPath フォルダパス
'-------------------------------------------------------------------------------
Public Sub OpenExplorer( _
    pFolderPath As String)
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.folderexists(pFolderPath) Then
        MsgBox "フォルダを指定してください" & vbCrLf & pFolderPath
        Exit Sub
    End If
    CreateObject("Shell.Application").ShellExecute pFolderPath
End Sub


'-------------------------------------------------------------------------------
'　エクスプローラーを開く（ファイルを選択状態にする）
'-------------------------------------------------------------------------------
'  param      : pFilePath
'  dependence : Sleep、OpenExplorer
'-------------------------------------------------------------------------------
Public Sub OpenExplorerFileSelected( _
    pFilePath As String)
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim folderPath As String
    folderPath = fso.GetParentFolderName(pFilePath)

    OpenExplorer folderPath

    Dim wb As Object
    Do While wb Is Nothing
        Sleep 500
        Set wb = GetExplorer(folderPath)
    Loop

    Call wb.document.SelectItem(CVar(pFilePath), 21) '1+4+16
    
End Sub
Private Function GetExplorer( _
    pFolder) As Object
    
    Dim objExp
    Set objExp = CreateObject("Shell.Application")
    Dim wb As Object
    For Each wb In objExp.Windows
        If wb.Name = "エクスプローラー" _
            And LCase(wb.document.folder.Self.path) = LCase(pFolder) Then
            Set GetExplorer = wb
            Exit Function
        End If
    Next
End Function


'-------------------------------------------------------------------------------
'  ファイルまたはフォルダをコピーする。
'-------------------------------------------------------------------------------
'  param : pSrcPath   コピー元ファイルパス（コピー元フォルダパス）
'  param : pDestPath  コピー先ファイルパス（コピー先フォルダパス）
'  note  : フォルダの場合は末尾の「\」有無で動作が変わらないように対応
'          vbs対応のため、型定義なし
'  dependence: JF
'-------------------------------------------------------------------------------
Public Sub CopyItem(pSrcPath, pDestPath)
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.folderexists(pSrcPath) Then
        If fso.folderexists(pDestPath) Then
            fso.CopyFolder JF(pSrcPath), JF(pDestPath) & "\", True 'True:上書き
        Else
            fso.CopyFolder JF(pSrcPath), JF(pDestPath), True  'True:上書き
        End If
    ElseIf fso.FileExists(pSrcPath) Then
        If fso.folderexists(pDestPath) Then
            fso.CopyFile pSrcPath, JF(pDestPath) & "\", True 'True:上書き
        Else
            fso.CopyFile pSrcPath, pDestPath, True 'True:上書き
        End If
    Else
        Err.Raise 1, , "CopyItemが失敗しました（独自エラー）"
    End If
End Sub


'-------------------------------------------------------------------------------
'  ファイルまたはフォルダを削除する。
'-------------------------------------------------------------------------------
'  param   : pSrcPath 削除するファイルまたフォルダのパス
'  note    : フォルダの場合は末尾の「\」有無で動作が変わらないように対応
'            vbs対応のため、型定義なし
'  dependence: JF
'-------------------------------------------------------------------------------
Public Sub DeleteItem(pSrcPath)
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.folderexists(pSrcPath) Then
        fso.DeleteFolder JF(pSrcPath), False 'False:読み取り専用を削除しない
    ElseIf fso.FileExists(pSrcPath) = True Then
        fso.DeleteFile pSrcPath, False 'False:読み取り専用を削除しない
    Else
        Err.Raise 1, , "DeleteItemが失敗しました（独自エラー）"
    End If
End Sub


'-------------------------------------------------------------------------------
'  ファイルまたはフォルダを移動する。
'-------------------------------------------------------------------------------
Public Sub MoveItem(pSrcPath, pDestPath)
    CopyItem pSrcPath, pDestPath
    DeleteItem pSrcPath
End Sub


'-------------------------------------------------------------------------------
'  文字列をファイルに書き込む。
'-------------------------------------------------------------------------------
'  param     : pFilePath ファイルパス
'  param     : pText  書き込む文字列
'  param     : pAdditionalMode   true :追加書き込み
'                              * false:通常書き込み
'  param     : pEncoding  * 0 : utf-8 BOMなし
'                           1 : shift_jis
'  dependence: MakeFolder
'  note      : フォルダが存在していなければ作成する。
'            : FSO版はUTF-8に対応していないため廃止。
'-------------------------------------------------------------------------------
Public Sub WriteFile( _
    pFilePath As String, _
    pText As String, _
    Optional pAdditionalMode As Boolean = False, _
    Optional pEncoding As Long = 0)
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim folderPath As String
    folderPath = fso.GetParentFolderName(pFilePath)
    If Not fso.folderexists(folderPath) Then
        Call MakeFolder(folderPath)
    End If

    With CreateObject("ADODB.Stream")
        If pEncoding = 0 Then
           .Charset = "utf-8"
        ElseIf pEncoding = 1 Then
           .Charset = "shift_jis"
        End If
        .Open
        
        '追加書き込みの場合、書き込み位置を末尾に移動。
        If pAdditionalMode And fso.FileExists(pFilePath) Then
            .LoadFromFile pFilePath
            .Position = .Size
        End If

        .WriteText pText, 0 '0:末尾改行なし
        
        'utf-8の場合、BOM削除
        If pEncoding = 0 Then
            .Position = 0
            .Type = 1  'バイナリ―モード
            .Position = 3
            Dim bin As Variant
            bin = .Read()
            .Position = 0
            If Not IsNull(bin) Then
                .Write = bin
            End If
            .SetEos
        End If
        
        .SaveToFile pFilePath, 2 '2:同名ファイルが存在してもエラーとしない
        .Close
    End With

End Sub

'-------------------------------------------------------------------------------
'  テキストファイルの文字列を全て取得する。
'-------------------------------------------------------------------------------
'  param     : pFilePath ファイルパス
'            : pEncodingType 文字コードタイプ  * 0 : utf-8
'                                                1 : shift_jis
'            : pLineSeparator 改行文字 * vbCrLf
'  return    : Variant(String配列)
'  note      : FSO版はUTF-8に対応していないため廃止
'-------------------------------------------------------------------------------
Public Function ReadFile( _
    pFilePath As String, _
    Optional pEncodingType As Long = 0, _
    Optional pLineSeparator As String = vbCrLf _
    ) As Variant
    
    With CreateObject("ADODB.Stream")
        If pEncodingType = 0 Then
           .Charset = "utf-8"
        ElseIf pEncodingType = 1 Then
           .Charset = "shift_jis"
        End If
        .Open
        .LoadFromFile pFilePath
        
        Dim arr As Variant
        arr = Split(.ReadText, pLineSeparator)
        ReadFile = arr
        .Close
    End With
End Function


'-------------------------------------------------------------------------------
'  プロパティファイルを読み込む。
'-------------------------------------------------------------------------------
'  param     : pFilePath ファイルパス
'  return    : プロパティ（Dictionary型）
'  note      :
'              Dim properties As Object
'              Set properties = ReadProperties("ファイルパス")
'              Debug.Print properties.item("キー")
'-------------------------------------------------------------------------------
Public Function ReadProperties(pFilePath As String) As Object
    
    Dim properties As Object
    Set properties = CreateObject("Scripting.Dictionary")

    Dim rows() As String
    rows() = ReadFile(pFilePath)
    Dim row As Variant
    For Each row In rows
        If row = "" Then
            GoTo continue1
        End If
        Dim key As String
        Dim value As String
        Dim var As Variant
        var = Split(row, "=")
        key = var(0)
        value = var(1)
        If key = "" Then
            GoTo continue1
        End If

        properties.Add key, value

continue1:
    Next
    Set ReadProperties = properties
End Function


'-------------------------------------------------------------------------------
'  一時ファイルパス文字列を生成する
'-------------------------------------------------------------------------------
'  param      : pPathTail 拡張子を付けたい場合に指定する。例 ".bat"
'  return     : 生成した一時ファイルパス文字列
'-------------------------------------------------------------------------------
Public Function CreateTempFilePath( _
    Optional pPathTail = "") As String
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    CreateTempFilePath = fso.GetSpecialFolder(2) & _
        "\" & fso.GetBaseName(fso.GetTempName) & pPathTail
End Function


'-------------------------------------------------------------------------------
'  テンプレート文字列に変数展開する
'-------------------------------------------------------------------------------
'  param      : pTemplateText テンプレート文字列
'  param      : pVal() 設定値
'  return     : 変数展開した文字列
'  note       : Here("私は${0}が${1}です", "ラーメン", "好き")
'-------------------------------------------------------------------------------
Public Function Here(pTemplateText, ParamArray pVal())
    Const PRE As String = "${"
    Const SUF As String = "}"
    Dim text As String
    text = pTemplateText
    Dim i As Long
    For i = 0 To UBound(pVal)
        text = Replace(text, PRE & i & SUF, pVal(i))
    Next
    Here = text
End Function


'-------------------------------------------------------------------------------
'  DBコネクションを取得する
'-------------------------------------------------------------------------------
'  param     :
'  return    :
'  note      :
'    DB接続文字列の例
'      例1  Provider=OraOLEDB.Oracle;
'           Data Source=(DESCRIPTION=(ADDRESS=(PROTOCOL=TCP)
'           (HOST=localhost)(PORT=1521))(CONNECT_DATA=(SERVICE_NAME=XE)));
'           User ID=scott;Password=tiger
'      例2  DSN=oracle xe;UID=scott;PWD=tiger
'-------------------------------------------------------------------------------
Public Function GetDBConnection(aDBConnectionString As String) As Object
    Dim cn As Object
    Set cn = CreateObject("ADODB.Connection")
    cn.Open aDBConnectionString
    Set GetDBConnection = cn
End Function


'-------------------------------------------------------------------------------
'  正規表現検索に使用するRegExpオブジェクトを作成する。
'-------------------------------------------------------------------------------
'  param       : pPattern 正規表現パターン
'  param retrun: rObjRegExp RegExpオブジェクト
'  note        :
'    '[How to use]
'    Dim regExpAbc As Object
'    CreateRegExp "c(c.+d)e", regExpAbc
'    Dim ms As Object
'    Dim m As Object
'    Set ms = regExpAbc.Execute("aabbccddee")
'    For Each m In ms
'        Debug.Print m.value '⇒ ccdde
'        Debug.Print m.submatches(0) '⇒ cdd
'    Next
'
'    'replace
'    Dim str As String
'    str = regExpAbc.Replace("aabbccddee", "xxx")  '⇒ aabbxxxe
'
'-------------------------------------------------------------------------------
Public Sub CreateRegExp(pPattern As String, ByRef prObjRegExp As Object)
    Set prObjRegExp = CreateObject("VBScript.RegExp")
    prObjRegExp.pattern = pPattern
    prObjRegExp.IgnoreCase = False    'False:大文字と小文字を区別する
    prObjRegExp.Global = True         'True:文字列全体を検索、False:1回目のマッチで終了
    prObjRegExp.multiLine = True      'True:通常、False:^や$が文字列全体の先頭と末尾になる
End Sub

'オブジェクトのcountが1件以上の場合trueを返す
Public Function HasItems(obj As Object)
    If Not obj Is Nothing And obj.Count >= 1 Then
        HasItems = True
        Exit Function
    End If
    HasItems = False
End Function


'-------------------------------------------------------------------------------
'  batファイルを実行する。
'-------------------------------------------------------------------------------
'  param     : pBatFilePath   batファイルパス
'  return    : batファイルの戻り値
'  note      :
'-------------------------------------------------------------------------------
Public Function ExecBat(pBatFilePath As String) As Long
    ExecBat = ExecCommand(pBatFilePath, 1, True)
End Function


'-------------------------------------------------------------------------------
'  シートが1個の新規ブックを作成する。
'-------------------------------------------------------------------------------
'  param     :
'  return    : 新規ブック
'  note      :
'-------------------------------------------------------------------------------
Public Function CreateOneSheetBook() As Workbook

    Dim bakSheetCount As Integer
    bakSheetCount = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Dim resultBook As Workbook
    Set resultBook = Workbooks.Add
    resultBook.Sheets(1).Cells.Font.Name = "ＭＳ ゴシック"
    Application.SheetsInNewWorkbook = bakSheetCount
    Set CreateOneSheetBook = resultBook

End Function


'-------------------------------------------------------------------------------
'  ワークシートの最終行の行位置を取得する
'-------------------------------------------------------------------------------
'  param      : pSheet  ワークシート
'  param      : pCol 最終行を検証する列位置
'  return     : 最終行の行位置
'  note       : UsedRangeはセルに値が無くても罫線や色が設定されていると行位置
'               として検出されてしまう。
'               findメソッド版は検索と置換ダイアログに影響がある為､廃止｡
'-------------------------------------------------------------------------------
Public Function GetLastRow( _
    pSheet As Worksheet, _
    Optional pCol As Long = 0) As Long
    
    Dim row As Long
    If pCol = 0 Then
        row = pSheet.UsedRange.rows(pSheet.UsedRange.rows.Count).row
    Else
        row = pSheet.Cells(pSheet.rows.Count, pCol).End(xlUp).row
    End If
    GetLastRow = row
End Function

'-------------------------------------------------------------------------------
'  ワークシートの最終列の列位置を取得する
'-------------------------------------------------------------------------------
'  param     : pSheet  ワークシート
'  param     : pRow 最終列を検証する行位置
'  return    : 最終列の列位置
'  note      : sedRangeはセルに値が無くても罫線や色が設定されていると行位置
'              として検出されてしまう｡
'              findメソッド版は検索と置換ダイアログに影響がある為､廃止｡
'-------------------------------------------------------------------------------
Public Function GetLastColumn( _
    pSheet As Worksheet, _
    Optional pRow As Long = 0) As Long
     
    Dim col As Long
    If pRow = 0 Then
        col = pSheet.UsedRange.Columns(pSheet.UsedRange.Columns.Count).Column
    Else
        col = pSheet.Cells(pRow, pSheet.Columns.Count).End(xlToLeft).Column
    End If
    GetLastColumn = col
End Function


'-------------------------------------------------------------------------------
'  CSVファイルをExcelで開く QueryTables版
'-------------------------------------------------------------------------------
'  param     : pCsvFilePath CSVファイルパス
'  param     : pSeparator 区切り文字
'  param     : aEncoding * 65001:UTF-8
'                          932:Shift-JIS
'  param     : pHeadingWindowLockFlag ヘッダ部ウィンドウ固定
'-------------------------------------------------------------------------------
Public Sub OpenCsv( _
    pCsvFilePath As String, _
    Optional pSeparator As String = ",", _
    Optional pEncoding As Long = 65001, _
    Optional pHeadingWindowLockFlag As String = False)
    
    Dim columnDataTypes(255) As Long
    Dim i As Long
    For i = 0 To 255
        columnDataTypes(i) = 2  '2:xlTextFormat
    Next
    
    Dim newSheet As Worksheet
    Set newSheet = CreateOneSheetBook.Sheets(1)
    newSheet.Cells.Font.Name = "ＭＳ ゴシック"
    
    Dim qt As QueryTable
    Set qt = newSheet.QueryTables.Add(Connection:="text;" & pCsvFilePath, _
        Destination:=newSheet.Range("A1"))
    qt.TextFileOtherDelimiter = pSeparator
    qt.TextFileColumnDataTypes = columnDataTypes
    qt.TextFilePlatform = pEncoding
   
    qt.Refresh
    qt.Delete
    newSheet.Cells.Columns.AutoFit
    
    If pHeadingWindowLockFlag Then
        newSheet.Range("A2").Select
        ActiveWindow.FreezePanes = False
        ActiveWindow.FreezePanes = True
    End If

End Sub


'-------------------------------------------------------------------------------
'  ブックが開いているかチェック
'-------------------------------------------------------------------------------
Public Function IsOpenedBook( _
    pBookName As String) As Boolean
    
    IsOpenedBook = False
    Dim book As Workbook
    For Each book In Workbooks
        If book.Name = pBookName Then
            IsOpenedBook = True
            Exit Function
        End If
    Next
End Function


'-------------------------------------------------------------------------------
'  シート存在チェック
'-------------------------------------------------------------------------------
Public Function ExistsSheet( _
    pBook As Workbook, _
    pSheetName As String) As Boolean
    
    Dim sheet As Worksheet
    For Each sheet In pBook.Worksheets
        If sheet.Name = pSheetName Then
            ExistsSheet = True
            Exit Function
        End If
    Next
    ExistsSheet = False
End Function


'-------------------------------------------------------------------------------
'  配列の最後に値を追加
'-------------------------------------------------------------------------------
'  param     : pArray 配列
'  return    : pValue 値
'  note      : pArrayに要素数未指定の配列変数を指定するとエラーになる。
'              その場合はArray()で初期化して渡す。
'                Dim arr As Variant
'                arr = Array()
'                Call AddArray(arr,"hoge")
'-------------------------------------------------------------------------------
Public Function AddArray( _
    ByRef pArray As Variant, _
    pValue As Variant)
    
    ReDim Preserve pArray(UBound(pArray) + 1)
    pArray(UBound(pArray)) = pValue
End Function


'-------------------------------------------------------------------------------
'  ブック、シートの体裁を整える
'-------------------------------------------------------------------------------
Public Sub FormatBook()
    
    '各シートの体裁を整える
    Dim sheet As Worksheet
    For Each sheet In ActiveWorkbook.Sheets
        If sheet.Visible = True Then
            sheet.Activate
            
            '表示倍率 85%
            ActiveWindow.Zoom = 85
            
            'A1セルを選択
            Application.Goto sheet.Range("A1"), True
        End If
    Next
    
    '先頭シートを選択
    Dim i As Long
    For i = 1 To ActiveWorkbook.Sheets.Count
        If ActiveWorkbook.Sheets(i).Visible = True Then
            ActiveWorkbook.Sheets(i).Select
            Exit Sub
        End If
    Next
End Sub