![](https://www.sibainu.org/wordpress/wp-content/uploads/2022/11/sibainu2221112top.jpg)
4つに分かれたコードを1つにまとめただけのものです。
UserForm のコード
UserForm1 の全コードです。
Option Explicit '// 64bit版 #If VBA7 And Win64 Then Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _ (ByVal hwnd As LongPtr) As Long '// 32bit版 #Else Private Declare Function SetForegroundWindow Lib "user32" _ (ByVal hwnd As Long) As Long #End If Private xlApp As Object Private FieldsDict As Dictionary Private myData() As Variant '----------------------------------------- ' Private Sub UserForm_Initialize() 'エクセルを開きます。 Set xlApp = CreateObject("Excel.Application") End Sub '----------------------------------------- 'ボタン「閉じる」のクリック Private Sub bu閉じる_Click() Unload Me End Sub '----------------------------------------- 'フォームが閉じるときに実行されるコード Private Sub UserForm_Terminate() Set xlApp = Nothing End Sub '----------------------------------------- 'ボタン「ダイヤログ」のクリック Private Sub buダイヤログ_Click() Dim FilePath As String FilePath = getFileName("Accessを選択") If FilePath = "" Then Exit Sub End If Call ConnectDB(FilePath) Call ShapeDraw End Sub '----------------------------------------- 'エクセルのダイヤログを開き選択したファイルのパスを返します。 Private Function getFileName(ByVal myTitle As String) As String Const msoFileDialogFilePicker = 3 Dim ThisPath As String Dim BUF As String '開いている PowerPoint のパス ThisPath = ActivePresentation.Path BUF = "" 'エクセルのダイヤログを開きます。 With xlApp 'これをしないとExcelはPowerPointに隠れたままです。 Call SetForegroundWindow(.hwnd) With .FileDialog(msoFileDialogFilePicker) .InitialFileName = ThisPath & "\" .AllowMultiSelect = False .Title = myTitle .Filters.Add "ACCESS", "*.accdb" .Filters.Add "すべてのファイル", "*.*" .FilterIndex = 1 .ButtonName = "開く" If .Show = True Then BUF = .SelectedItems(1) End If End With 'エクセルを閉じる .Quit End With getFileName = BUF End Function '----------------------------------------- 'Access に接続してデータを配列に取得します。 Private Sub ConnectDB(ByVal strFileName As String) Dim ADOCn As Object Dim ADORs As Object Dim Data() As Variant Dim mySQL As String Dim myDate As String Dim I As Long Dim J As Long 'ADODBコネクションオブジェクトを作成します。 Set ADOCn = CreateObject("ADODB.Connection") 'Access ファイルに接続します。 ADOCn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _ "Data Source = " & strFileName & ";" '今日の日を判定日とします。 myDate = Format(Date, "yyyy-mm-dd") 'SQL文の作成 '条件は、判定日が開始日以降で、終了日以前もしくは終了日が空の場合とします。 'A.終了日を SWITCH 関数で場合分けします。 mySQL = "SELECT A.区画ID" mySQL = mySQL & ", X.登録番号" mySQL = mySQL & ", X.氏名" mySQL = mySQL & " FROM MT_区画 AS A" mySQL = mySQL & " LEFT JOIN " mySQL = mySQL & "(SELECT B.区画ID" mySQL = mySQL & ", B.登録番号" mySQL = mySQL & ", C.氏名" mySQL = mySQL & " FROM MT_契約 AS B" mySQL = mySQL & " LEFT JOIN" mySQL = mySQL & " MT_契約者 AS C" mySQL = mySQL & " ON B.契約者ID = C.契約者ID" mySQL = mySQL & " WHERE B.開始日 <= '" & myDate & "'" mySQL = mySQL & " AND SWITCH(B.終了日 IS NULL , '9999-12-31'" mySQL = mySQL & ", B.終了日 = '', '9999-12-31'" mySQL = mySQL & ", TRUE, B.終了日) >= '" & myDate & "') AS X" mySQL = mySQL & " ON A.区画ID = X.区画ID" mySQL = mySQL & ";" 'レコードセットを作成します。 Set ADORs = CreateObject("ADODB.Recordset") ADORs.Open mySQL, ADOCn, adOpenStatic, adLockReadOnly 'フィールド名とインデックスを対応させたハッシュテーブルを作成します。 Set FieldsDict = New Dictionary With FieldsDict For I = 0 To ADORs.Fields.Count - 1 .Add ADORs.Fields(I).Name, I Next I End With 'データを書き出す配列を作成します。 ReDim Data(ADORs.Fields.Count - 1, ADORs.RecordCount - 1) 'レコードセットのデータを配列に書き出します。 Data = ADORs.GetRows 'データを取得したので切断します。 ADORs.Close Set ADORs = Nothing ReDim myData(UBound(Data, 2), UBound(Data, 1)) For I = 0 To UBound(Data, 2) For J = 0 To UBound(Data, 1) myData(I, J) = Data(J, I) Next J Next I End Sub '----------------------------------------- 'AccessのデータをShapeに書き込みます。 Private Sub ShapeDraw() Dim SlideNum As Long Dim KeiyakuDict As Dictionary Dim Shp As Shape Dim BUF As String Dim V As String Dim I As Long '後の処理を考え、区画IDをキーとするハッシュテーブルを作成します。 Set KeiyakuDict = New Dictionary With KeiyakuDict For I = 0 To UBound(myData, 1) '配列 mtData の要素は Variant 型なので Null ということもあります。 'Null の場合 BUF には空 "" が入ります。 BUF = NZ(myData(I, FieldsDict("登録番号"))) If BUF = "" Then BUF = NZ(myData(I, FieldsDict("氏名"))) If BUF <> "" Then V = BUF Else V = "" End If Else V = BUF BUF = NZ(myData(I, FieldsDict("氏名"))) If BUF <> "" Then V = V & vbLf & BUF End If End If '重複した時の処理 If .Exists(myData(I, FieldsDict("区画ID"))) Then If KeiyakuDict(myData(I, FieldsDict("区画ID"))) <> "重複" Then KeiyakuDict(myData(I, FieldsDict("区画ID"))) = "重複" End If Else .Add myData(I, FieldsDict("区画ID")), V End If Next I End With 'スライド2に作ったから2です。状況に応じて決めます。 For SlideNum = 2 To 2 For Each Shp In ActivePresentation.Slides(SlideNum).Shapes 'ハッシュテーブルと照合します。 If KeiyakuDict.Exists(Shp.Name) Then If KeiyakuDict(Shp.Name) <> "" Then With Shp.TextFrame 'テキストのベースオブジェクトを中央に配置します。 .HorizontalAnchor = msoAnchorCenter .MarginLeft = 1 .MarginRight = 1 With .TextRange .Text = KeiyakuDict(Shp.Name) .Font.Size = 10 'テキストを中央に配置します。 .ParagraphFormat.Alignment = msoAlignCenter End With End With Else With Shp.TextFrame 'テキストのベースオブジェクトを中央に配置します。 .HorizontalAnchor = msoAnchorCenter .MarginLeft = 1 .MarginRight = 1 With .TextRange .Text = Shp.Name .Font.Size = 16 'テキストを中央に配置します。 .ParagraphFormat.Alignment = msoAlignCenter End With End With End If End If Next Shp Next SlideNum Set KeiyakuDict = Nothing End Sub '----------------------------------------- 'AccessにあるNz関数がないので状況に応じて自作します。 Private Function NZ(ByVal Val As Variant, _ Optional def As Variant) As Variant Dim Res As Variant If IsMissing(def) Then Res = "" Else Res = def End If If IsNull(Val) Then '何もしません ElseIf IsEmpty(Val) Then '何もしません Else Res = Val End If NZ = Res End Function
UserForm
デフォルトで挿入されたフォーム「UseForm1」にボタン「bu閉じる」「buダイヤログ」を配置しただけのフォームです。
![](https://www.sibainu.org/wordpress/wp-content/uploads/2022/11/wp_20221112form11.jpg)