2021-09-23

【VBA】参照設定の追加

Private Const 参照設定VBA           As String = "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA7.1\VBE7.DLL"
Private Const 参照設定Excel         As String = "C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE"
Private Const 参照設定OLE           As String = "C:\Windows\System32\stdole2.tlb"
Private Const 参照設定OfficeLibrary As String = "C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL"
Private Const 参照設定ADODB         As String = "C:\Program Files\Common Files\System\ado\msado15.dll"
Private Const 参照設定Regular       As String = "C:\Windows\System32\vbscript.dll\3"
Private Const 参照設定Scripting     As String = "C:\Windows\System32\scrrun.dll"

Sub 参照設定一覧表示()

    On Error GoTo ■エラー処理
    
    Dim 設定済の内容 As Object
    
    For Each 設定済の内容 In このブック.VBProject.References
        With 設定済の内容
            Debug.Print _
                "名称" & vbTab & vbTab & "：" & .Name & vbCrLf & _
                "参照設定名" & vbTab & "：" & .Description & vbCrLf & _
                "フルパス" & vbTab & "：" & .FullPath & vbCrLf & _
                "------------------------"
        End With
    Next
    
    Debug.Print "●参照設定一覧表示の成功●"
    GoTo ■終了処理
    
■エラー処理:
    If Err.Number = 1004 Then
        MsgBox "「Excelのオプション」" & vbCrLf _
             & "→「マクロの設定」" & vbCrLf _
             & "→「開発者向けのマクロ設定」" & vbCrLf _
             & "→「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを入れてください。" _
             , , "Excelの設定変更が必要です。"
    Else
        Debug.Print "▲参照設定一覧表示のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    End If
    
■終了処理:

End Sub

Private Function 参照設定あり(ByRef 確認対象フルパス As String) As Boolean
    
    On Error GoTo ■エラー処理
    
    Dim 設定済の内容 As Object
    
    参照設定あり = False
    
    For Each 設定済の内容 In このブック.VBProject.References
        If 設定済の内容.FullPath = 確認対象フルパス Then
            参照設定あり = True
            Exit For
        End If
    Next
    
    GoTo ■終了処理
    
■エラー処理:
    If Err.Number = 1004 Then
        MsgBox "「Excelのオプション」" & vbCrLf _
             & "→「マクロの設定」" & vbCrLf _
             & "→「開発者向けのマクロ設定」" & vbCrLf _
             & "→「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを入れてください。" _
             , , "Excelの設定変更が必要です。"
    Else
        Debug.Print "▲参照設定ありのエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    End If
    
■終了処理:

End Function

Sub 参照設定追加処理()
    
    On Error GoTo ■エラー処理
    
    With ActiveWorkbook.VBProject.References
        If 参照設定あり(参照設定VBA) = False Then .AddFromFile 参照設定VBA
        If 参照設定あり(参照設定Excel) = False Then .AddFromFile 参照設定Excel
        If 参照設定あり(参照設定OLE) = False Then .AddFromFile 参照設定OLE
        If 参照設定あり(参照設定OfficeLibrary) = False Then .AddFromFile 参照設定OfficeLibrary
        If 参照設定あり(参照設定ADODB) = False Then .AddFromFile 参照設定ADODB
        If 参照設定あり(参照設定Regular) = False Then .AddFromFile 参照設定Regular
        If 参照設定あり(参照設定Scripting) = False Then .AddFromFile 参照設定Scripting
    End With
    
    参照設定一覧表示
    
    Debug.Print "●参照設定追加処理の成功●"
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲参照設定追加処理のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:

End Sub

2021-09-23

【VBA】先頭文字列追加　末尾文字列追加

Function 先頭文字列追加( _
                          ByRef 対象文字列 As String _
                        , ByRef 先頭文字列 As String _
                        , Optional ByRef 既にあれば追加しない As Boolean = True _
                        ) As String
    If 既にあれば追加しない Then
        先頭文字列追加 = IIf(対象文字列 Like "*" & 先頭文字列, 対象文字列, 対象文字列 & 先頭文字列)
    Else
        先頭文字列追加 = 対象文字列 & 先頭文字列
    End If
End Function

Function 末尾文字列追加( _
                          ByRef 対象文字列 As String _
                        , ByRef 末尾文字列 As String _
                        , Optional ByRef 既にあれば追加しない As Boolean = True _
                        ) As String
    If 既にあれば追加しない Then
        末尾文字列追加 = IIf(対象文字列 Like "*" & 末尾文字列, 対象文字列, 対象文字列 & 末尾文字列)
    Else
        末尾文字列追加 = 対象文字列 & 末尾文字列
    End If
End Function

2021-09-23

【VBA】別ファイルのシートコピー

Function 別ブックのシート取込( _
                          ByRef 対象ファイルのパス As String _
                        , ByRef 対象シート一覧 As Variant _
                        , Optional ByRef シートを表示する As Variant = xlSheetVisible _
                        )
    
    On Error GoTo ■エラー処理
    
    Dim ファイルシステム As Object
    Dim シート As Worksheet
    Dim 対象シート名 As Variant
    Dim 対象ブック As Workbook
    Dim 取込成功 As Boolean
    Dim 処理用対象シート一覧() As Variant
    Dim 存在しないシート一覧 As String
    
    If ブックを開く(対象ファイルのパス, 表示で開く:=False, 読み取り専用:=True, 読み取り推奨メッセージを非表示にする:=True) = False Then GoTo ■終了処理
    
    Set ファイルシステム = CreateObject("Scripting.FileSystemObject")
    Set 対象ブック = Workbooks(ファイルシステム.GetFileName(対象ファイルのパス))
    
    '対象シート一覧が単一（配列でない）場合配列に変換する
    If IsArray(対象シート一覧) Then
        処理用対象シート一覧 = 対象シート一覧
    Else
        ReDim 処理用対象シート一覧(0)
        処理用対象シート一覧(0) = 対象シート一覧
    End If
    
    For Each 対象シート名 In 処理用対象シート一覧
        取込成功 = False
        For Each シート In 対象ブック.Worksheets
            If シート.Name = 対象シート名 Then
                シート.Copy after:=集計シート
                このブック.Worksheets(対象シート名).Visible = シートを表示する
                取込成功 = True
                Exit For
            End If
        Next
        If 取込成功 = False Then Exit For
    Next
    
    If 取込成功 Then
        Debug.Print "●別ブックのシート取込の成功●"
    Else
        Debug.Print "▲別ブックのシート取込の失敗▲"
    End If
    別ブックのシート取込 = 取込成功
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲別ブックのシート取込のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:
    Call ブックを閉じる(対象ブック.Name, False)

End Function

2021-09-21

【VBA】２つのシートを結合して検索するSQL

■関連情報 - 【VBA】別ファイルのシートコピー

DB関連モジュール

Option Explicit

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"

マスターテーブルと明細テーブルから集計テーブルを作成する

Sub 複数シートの集計処理()
    
    On Error GoTo ■エラー処理
    
    Dim DB接続情報 As Object
    Dim 検索結果 As Object
    Dim 行№ As Long
    Dim 列№ As Long
    Dim 項目№ As Long
    Dim SQL文 As String
    
    Call 開始前処理
    
    If 別ブックのシート取込("C:\test\ADO_MASTER.xlsx", "マスター", False) = False Then GoTo ■終了処理
    If 別ブックのシート取込("C:\test\ADO_MEISAI.xlsx", "明細", False) = False Then GoTo ■終了処理
    
    Call DB接続処理(DB接続情報, 検索結果, このブック.FullName)
    
    SQL文 = ""
    SQL文 = SQL文 & " SELECT"
    SQL文 = SQL文 & "   FORMAT(明細.購入日,'yyyy/mm/dd') AS 購入日"
    SQL文 = SQL文 & " , マスタ.商品名 "
    SQL文 = SQL文 & " , 明細.個数 "
    SQL文 = SQL文 & " , マスタ.金額 "
    SQL文 = SQL文 & " , マスタ.金額 * 明細.個数 AS 小計 "
    SQL文 = SQL文 & " FROM"
    SQL文 = SQL文 & "   [明細$C2:F] AS 明細"
'    SQL文 = SQL文 & " INNER JOIN"
'    SQL文 = SQL文 & " RIGHT JOIN"
    SQL文 = SQL文 & " LEFT JOIN"
    SQL文 = SQL文 & "   [マスター$] AS マスタ"
    SQL文 = SQL文 & " ON"
    SQL文 = SQL文 & "   (明細.商品コード=REPLACE(マスタ.商品コード,'.xxxx',''))"
    SQL文 = SQL文 & " WHERE"
    SQL文 = SQL文 & "   FORMAT(明細.購入日,'yyyy')='2020'"
    SQL文 = SQL文 & " ORDER BY"
    SQL文 = SQL文 & "   明細.購入日"
    SQL文 = SQL文 & " , マスタ.商品名"
    
    検索結果.CursorLocation = adUseClient
    検索結果.Open SQL文, DB接続情報, adOpenDynamic, adLockOptimistic, adCmdText
    With 集計シート.ListObjects("集計テーブル")
        If .ListRows.Count > 0 Then
            .DataBodyRange.Delete
        End If
        With .HeaderRowRange(1)
            集計シート.Cells(.Offset(1, 0).Row, .Column).CopyFromRecordset 検索結果
        End With
    End With
    
    Debug.Print "●集計処理の成功●"
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲集計処理のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:
    Call DB切断処理(DB接続情報, 検索結果)
    Call シート削除(Array("マスター", "明細"), このブック)
    Call 終了前処理
    
End Sub

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 レコードセット.State = adStateOpen Then レコードセット.Close
    If Not レコードセット Is Nothing Then Set レコードセット = Nothing
    
    If DB接続情報.State = adStateOpen Then DB接続情報.Close
    If Not DB接続情報 Is Nothing Then Set DB接続情報 = Nothing
    
    Debug.Print "●DB切断処理の成功●"
    DB切断処理 = True
    
    GoTo ■終了処理
    
■エラー処理:
    Debug.Print "▲DB切断処理のエラー▲" & vbCrLf & vbTab & Err.Number & vbTab & Err.Description
    
■終了処理:

End Function

2021-09-13

notionから記事はコチラ

notionの記事公開です https://astonishing-wandflower-0b6.notion.site/notion-f4d167700caa43469cb98f4da148becc

2021-09-12

【VBA】設定一覧シートから設定情報を取得する

f:id:yukkuri_kame3:20210912183749g:plain — 構成イメージ

設定の取得コード

Property Get val(ByRef ParamName As String) As String
    Dim L As ListObject
    For Each L In shSetting.ListObjects
        If L.Name = "設定一覧" Then
            val = Cells(L.ListColumns("設定値").Range.Column, _
                        L.ListColumns("設定名").Range.Find(ParamName).Row _
                        )
            GoTo Finally
        End If
    Next
    MsgBox "指定の設定が存在しないか、当ファイルの設定一覧が破損している可能性があります"
Finally:
End Property

設定取得の例

Sub test()
    Dim p As clsProperty
    Set p = New clsProperty
    Debug.Print p.val("監視フォルダ")
End Sub

実行結果

C:\Users\ユーザ名\Desktop\監視対象のフォルダ

2021-09-05

【VBA】方眼紙解析　項目範囲特定

'#######################################
'方眼フォーマット　項目範囲取得
'#######################################
Sub GetFieldArea()
    On Error GoTo Catch
    
    Dim i As Integer
    Dim j As Integer
    Dim rng As Range
    Dim strMergeArea As String
    
    Dim CN As ADODB.Connection
    Dim rsArea As ADODB.Recordset     '新規に作成するレコードセット
    
    '新規にレコードセットを作成
    Set rsArea = New ADODB.Recordset
    
    '取得したい項目名を定義
    rsArea.Fields.Append "項目1", adVarChar, 20
    rsArea.Fields.Append "項目2", adVarChar, 20
    rsArea.Fields.Append "項目3", adVarChar, 20

    rsArea.Open
    
    rsArea.AddNew
    
    For i = 0 To rsArea.Fields.Count - 1
        With ThisWorkbook.Worksheets("方眼攻略")
            Set rng = .cells.Find(rsArea.Fields(i).Name, LookAt:=xlWhole)
            strMergeArea = rng.MergeArea.Address
            rng.UnMerge                 '結合セルの解除
            j = 0
            '項目の左端を取得
            While rng.Offset(0, j).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                j = j - 1               'セルを左へ移動
            Wend
            Set rng = rng.Offset(0, j)
            j = 0
            '項目の右端を取得
            While rng.Offset(0, j).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
                j = j + 1               'セルを右へ移動
            Wend
            rsArea.Fields(i) = RegExpReplace(Replace(rng.MergeArea.Resize(1, 1 + j).Address, "$", ""), "\d*", "", , True)
            Range(strMergeArea).Merge   '結合セルを戻す
        End With
    Next
    
    
    GoTo Finally
Catch:
    Debug.Print "■エラー【GetFieldArea】" _
                & vbCrLf & Err.Number & vbTab & Err.Description
    MsgBox "エラーが発生しました", , "エラー"
Finally:
    rsArea.Close
    Set rsArea = Nothing
End Sub

ゆっくり開発

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

【VBA】参照設定の追加

【VBA】先頭文字列追加　末尾文字列追加

【VBA】別ファイルのシートコピー

【VBA】２つのシートを結合して検索するSQL

notionから記事はコチラ

【VBA】設定一覧シートから設定情報を取得する

【VBA】方眼紙解析　項目範囲特定