ゆっくり開発

思いついた便利コードを気ままにアップしていきます。公開しているソースコードはすべてMITライセンスです。

【VBA】正規表現　置き換え 

'#######################################
'正規表現置換
'【概要】
'       正規表現で文字列置換する
'【参照設定】
'       Microsoft VBScript Regular Expressions 5.5
'【引数】
'            対象文字列                 ：変更前文字列
'            パターン                   ：検索条件
'            置き換え文字列             ：置き換える文字列
'   [省略可] 大文字と小文字を区別しない ：大文字と小文字を区別しないとき：True、デフォルト：False
'   [省略可] 文字列全体が対象           ：検索対象の文字列内で、文字列全体を検索する：True、デフォルト：False
'【参考サイト】
'       ・https://excel-ubara.com/excelvba4/EXCEL232.html
'       ・https://www.megasoft.co.jp/mifes/seiki/
'#######################################
Function 正規表現置換( _
                       ByRef 対象文字列 As String _
                     , ByRef パターン As String _
                     , ByRef 置き換え文字列 As String _
                     , Optional ByRef 大文字と小文字を区別しない As Boolean = False _
                     , Optional ByRef 文字列全体が対象 As Boolean = False _
                     ) As String
    
    With CreateObject("VBScript.RegExp")
        .Global = 文字列全体が対象
        .Pattern = パターン
        .IgnoreCase = 大文字と小文字を区別しない
        正規表現置換 = .Replace(対象文字列, 置き換え文字列)
    End With

End Function

【VBA】拡張子取得　ユーザー定義関数 

'拡張子取得
Function GetExtension(ByRef パス As String) As String
    
    Dim str As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    str = fso.GetExtensionName(パス)
    GetExtension = SplitString(str, "]", 1)
    
    If Not fso Is Nothing Then Set fso = Nothing

End Function
'ユーザー定義関数の説明登録
'ブックのオープンイベントなどで呼び出す
Sub AddUDFToCustomCategory()
    
    'オプションの設定方法は下記参照
    '   https://docs.microsoft.com/ja-jp/office/vba/api/excel.application.macrooptions

    Application.MacroOptions _
          Macro:="GetExtension" _
        , Description:="対象パスから拡張子を取得します" _
        , Category:=9 _
        , ArgumentDescriptions:=Array( _
                                      "を指定します" _
                                )
End Sub

【VBA】文字列分割　ユーザー定義関数 

'文字列分割
Function SplitString( _
                      ByRef 対象文字列 As String _
                    , ByRef 区切り文字列 As String _
                    , Optional ByRef 取得位置 As Integer = 1 _
                    ) As Variant
    
    Dim var As Variant
    var = Split(対象文字列, 区切り文字列)
    SplitString = var(IIf(取得位置 < 0, UBound(var) + 1 + 取得位置, 取得位置 - 1))

End Function
'ユーザー定義関数の説明登録
'ブックのオープンイベントなどで呼び出す
Sub AddUDFToCustomCategory()
    
    'オプションの設定方法は下記参照
    '   https://docs.microsoft.com/ja-jp/office/vba/api/excel.application.macrooptions
    
    Application.MacroOptions _
          Macro:="SplitString" _
        , Description:="「対象文字列」を「区切り文字列」で分割します。" _
        , Category:=7 _
        , ArgumentDescriptions:=Array( _
                                      "分割したい文字列を指定します" _
                                    , "分割する文字列を指定します" _
                                    , "取得したい文字列の位置を整数で指定します" _
                                    & vbCrLf & "1以上：左からの順番" _
                                    & vbCrLf & "-1以下：右からの順番" _
                                )
End Sub

【VBA】ExcelにDB接続 

'#######################################
'ExcelDB化接続
'【概要】
'       DB接続
'【引数】
'            ExcelPath                  ：接続先Excelのフルパス
'   [省略可] HeaderExists               ：ヘッダ有:True(既定値)、無:False）
'【戻り値】
'            Boolean                    ：True：正常終了   False：異常終了
'#######################################
Function ExcelDBconnect( _
                       ByRef ExcelPath As String _
            , Optional ByRef HeaderExists As Boolean = True _
        ) As Boolean
    On Error GoTo Catch
    
    Const adOpenKeyset = 1
    Const adLockReadOnly = 1
     
    Dim cn As Object
    Dim strSQL As String    'SQL文字列
    Dim fso As Object       'File System Object
    Dim wsh As Variant      'Windows Scripting Host
    
    ExcelDBconnect = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsh = CreateObject("WScript.Shell")
     
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Provider = "Microsoft.ACE.OLEDB.12.0"
    
    'ファイルが存在しない場合、処理終了
    If fso.FileExists(ExcelPath) = False Then
        MsgBox "対象ファイルが存在しません。ファイルを確認してください" & vbCrLf & ExcelPath
        GoTo Finally
    End If
    
    '接続プロパティ
    'HDR=YES    1行目がヘッダになる
    'HDR=NO     F1,F2,F3・・・と番号が振られる。
    cn.Properties("Extended Properties") = "Excel 12.0;HDR=" & IIf(HeaderExists, "YES", "NO") & ";IMEX=1"
     
    cn.Open ExcelPath '接続
    
    '接続状況をチェック
    If cn.State = adStateOpen Then
        Debug.Print "■接続成功■" & vbTab & ExcelPath
    Else
        Debug.Print "■接続失敗■" & vbTab & ExcelPath
        GoTo Finally
    End If
    
    ExcelDBconnect = True
    
    GoTo Finally
Catch:
    ExcelDBconnect = False
    Debug.Print "■エラー【ExcelDBconnect】" & vbCrLf & Err.Number & vbTab & Err.Description
    MsgBox "エラーが発生しました", , "エラー"
Finally:
    If Not fso Is Nothing Then Set fso = Nothing    '不要オブジェクト開放
    If Not wsh Is Nothing Then Set wsh = Nothing    '不要オブジェクト開放
End Function

シンプルな設定

Private Const DBプロバイダ As String = "Microsoft.ACE.OLEDB.12.0"
Private Const DBプロパティ As String = "Extended Properties"
Private Const DBExcelバージョン As String = "Excel 12.0"

シンプルに接続

Private Function DB接続処理( _
               ByRef DB接続情報 As Object _
             , ByRef レコードセット As Object _
             , ByRef 接続先ファイルのフルパス As String _
             ) As Boolean
    
    On Error GoTo ■エラー処理
    
    DB接続処理 = False
    
    Set DB接続情報 = CreateObject("ADODB.Connection")
    Set レコードセット = CreateObject("ADODB.Recordset")
    
    With DB接続情報
        .Provider = DBプロバイダ
        .Properties(DBプロパティ) = DBExcelバージョン
        .Open 接続先ファイルのフルパス
    End With
    
    Debug.Print "●DB接続処理の成功●"
    DB接続処理 = True
    
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲DB接続処理のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:

End Function

シンプルに切断

Private Function DB切断処理( _
                      ByRef DB接続情報 As Object _
                    , ByRef レコードセット As Object _
                    ) As Boolean
    
    On Error GoTo ■エラー処理
    
    DB切断処理 = False
    
    If Not レコードセット Is Nothing Then
        If レコードセット.State = adStateOpen Then レコードセット.Close
        Set レコードセット = Nothing
    End If
    
    If Not DB接続情報 Is Nothing Then
        If DB接続情報.State = adStateOpen Then DB接続情報.Close
        Set DB接続情報 = Nothing
    End If
    
    Debug.Print "●DB切断処理の成功●"
    DB切断処理 = True
    
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲DB切断処理のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:

End Function

【VBA】関数のひな形 

'#######################################
'ひな形 Sub
'【概要】
'       ひな形です
'【引数】
'            aaaaaaaa                   ：
'   [省略可] bbbbbbb                    ：
'#######################################
Sub ひな形_S( _
                       ByRef aaaaaaaa As Variant _
            , Optional ByRef bbbbbbb As Variant _
        )
    On Error GoTo Catch
    
    
    
    GoTo Finally
Catch:
    Debug.Print "■エラー【ひな形_S】" & vbCrLf & Err.Number & vbTab & Err.Description
    MsgBox "エラーが発生しました", , "エラー"
Finally:
End Sub
'#######################################
'ひな形 Function
'【概要】
'       ひな形です
'【引数】
'            aaaaaaaa                   ：
'   [省略可] bbbbbbb                    ：
'【戻り値】
'            Boolean                    ：True：正常終了   False：異常終了
'#######################################
Function ひな形_F( _
                       ByRef aaaaaaaa As Variant _
            , Optional ByRef bbbbbbb As Variant _
        ) As Boolean
    On Error GoTo Catch
    
    
    ひな形_F = True
    
    GoTo Finally
Catch:
    ひな形_F = False
    Debug.Print "■エラー【ひな形_F】" & vbCrLf & Err.Number & vbTab & Err.Description
    MsgBox "エラーが発生しました", , "エラー"
Finally:
End Function