取引先CD別でexcel出力し、添付してメールを送りたいです。

Question

お世話になります。
初心者のためお力添え願います。

前提・実現したいこと

access2019を使用しております。
以下の単価一覧クエリから、取引先CD別で、C:\取引先別単価表フォルダへexcel出力し、
連絡先テーブルにある同一の取引先CDのメールアドレスへ添付してメールを送りたいです。
excelのファイル名を取引先名でお願いします。

#####連絡先テーブル

取引先CD	取引先名	メールアドレス
A	山田商店	[e-mail]
B	佐藤青果	[e-mail]
C	鈴木屋	[e-mail]
・・・	・・・	・・・

#####単価一覧クエリ

取引先CD	取引先名	品名	単価
A	山田商店	りんご	100
A	山田商店	ぶどう	200
A	山田商店	バナナ	50
B	佐藤青果	なし	100
C	鈴木屋	キウイ	80
C	鈴木屋	マンゴー	300
・・・	・・・	・・・	・・・

#####C:\取引先別単価表\山田商店.xlsx

取引先CD	取引先名	品名	単価
A	山田商店	りんご	100
A	山田商店	ぶどう	200
A	山田商店	バナナ	50

#####C:\取引先別単価表\佐藤青果.xlsx

取引先CD	取引先名	品名	単価
B	佐藤青果	なし	100

#####C:\取引先別単価表\鈴木屋.xlsx

取引先CD	取引先名	品名	単価
C	鈴木屋	キウイ	80
C	鈴木屋	マンゴー	300

#####最終的に
山田商店.xlsxを、[e-mail]へメール
佐藤青果.xlsxを、[e-mail]へメール
鈴木屋.xlsxを、[e-mail]へメール
以下、取引先CD全てで繰り返したいです。

自分で調べたことや試したこと

excel添付しメール送信するvbsを別で作成し、1つのクエリのexcelに出力と、vbsの実行をマクロで行うことは出来たのですが、
取引先CD別に全てexcel出力して、かつ取引先CDに対してメール送信する方法が思い浮かびませんでした。

よろしくお願いいたします。

Comments

[kuma_kuma_]

ごめんなさい細かい事なんですが「なし」は「梨」という事でいいのでしょうか？

[3298.f56]

はい、「梨」の意味になります。
表記が分かりづらかったですね、すいません。

Answer 1

DoCmd.TransferSpreadsheetを使う想定
クエリは削除追加で取引先毎に更新されます。

とりあえずADOで書いておきます。
DAOでも大丈夫です。

'参照設定に[Microsoft ActiveX Data Object 6.1 Library]を設定してください
'参照設定に[Microsoft ADO Ext. 6.0 for DDL and Security]を設定してください
Sub Test2()

    Dim cnn             As ADODB.Connection 'コネクション
    Dim RecMain         As ADODB.Recordset  'レコードセット
    Dim SQLs            As String           'SQL文字列
    Dim cat             As ADOX.Catalog
    Dim viw             As ADOX.View
    Dim cmd             As ADODB.Command
    Dim strQueryName    As String
    Dim strPath         As String

On Error GoTo Test_Err:
    
    strQueryName = "Excel出力クエリ"

    '----- データベース接続
    Set cnn = CurrentProject.Connection
    
    '----- レコードセット取得(スナップショット)
　　SQLs = "SELECT 連絡先テーブル.取引先CD, "
　　SQLs = "SELECT 連絡先テーブル.取引先名, "
    SQLs = SQLs & "連絡先テーブル.[メールアドレス] "
    SQLs = SQLs & "FROM 連絡先テーブル "
    SQLs = SQLs & "ORDER BY 連絡先テーブル.取引先CD; "
    Set RecMain = New ADODB.Recordset
    With RecMain
        .ActiveConnection = cnn
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open Source:=SQLs
    End With
    
    '----- 取引先の情報取得
    Do Until RecMain.EOF
        '----- 取引先毎の情報取得
        SQLs = "SELECT 単価一覧クエリ.取引先CD, 単価一覧クエリ.取引先名, 単価一覧クエリ.品名, 単価一覧クエリ.単価 "
        SQLs = SQLs & " FROM 単価一覧クエリ "
        SQLs = SQLs & "WHERE (((単価一覧クエリ.取引先CD)=""" & RecMain![取引先CD] & """)) "
        SQLs = SQLs & "ORDER BY 単価一覧クエリ.取引先CD, 単価一覧クエリ.品名; "

        Set cat = New ADOX.Catalog
        Set cmd = New ADODB.Command
        cat.ActiveConnection = CurrentProject.Connection
        
        '----- クエリーの削除
        For Each viw In cat.Views
            If viw.Name = strQueryName Then
                cat.Views.Delete strQueryName
                Exit For
            End If
        Next viw
        
        '----- クエリーの追加
        Set cmd.ActiveConnection = cat.ActiveConnection
        cmd.CommandText = SQLs
        cat.Views.Append strQueryName, cmd

        Set cat = Nothing
        Set cmd = Nothing

        '----- Excelファイルエクスポート
        strPath = "C:\取引先別単価表\" & RecMain![取引先名] & ".xlsx"
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, strQueryName, strPath, True

        '----- 次のレコードへ移動
        RecMain.MoveNext
    Loop

Test_End:
On Error Resume Next
    '----- 終了処理
    Rec.Close:        Set Rec = Nothing
    RecMain.Close:    Set RecMain = Nothing
    cnn.Close:        Set cnn = Nothing
Exit Sub

'----- エラー処理
Test_Err:
Resume Test_End:
End Sub

Comments

[3298.f56]

kuma_kuma_様
ご回答ありがとうございます。
コードを試させて頂きます。
まずはお礼申し上げます。

[3298.f56]

kuma_kuma_様
コードを実行させてみましたが、"C:\取引先別単価表\"フォルダの作成もされず、
excelの出力もされませんでした。

自分自身の勉強のため、頂いたコードについて検証させて頂きます。
またベストアンサーとさせて頂きます。
ありがとうございました。

[kuma_kuma_]

フォルダ作成は別に処理しといたほうがよいよ
https://programming-study.com/technology/vba-folda/

[3298.f56]

kuma_kuma_様
アドバイスありがとうございます。
サイトを参考にさせて頂きます。

Answer 2

こんな感じで2重ループにすれば問題ないかと思いますが？

とりあえずADOで書いておきます。
DAOでも大丈夫です。

でもDoCmd.TransferSpreadsheetを使ってExcel出力していると、
この方法が使えませんのでそちらは別回答に書きます。

'参照設定に[Microsoft ActiveX Data Object 6.1 Library]を設定してください
Sub Test()

    Dim cnn             As ADODB.Connection 'コネクション
    Dim RecMain         As ADODB.Recordset  'レコードセット
    Dim Rec             As ADODB.Recordset  'レコードセット
    Dim SQLs            As String           'SQL文字列

On Error GoTo Test_Err:
    
    '----- データベース接続
    Set cnn = CurrentProject.Connection
    
    '----- レコードセット取得(スナップショット)
　　SQLs = "SELECT 連絡先テーブル.取引先CD, "
    SQLs = SQLs & "連絡先テーブル.[メールアドレス] "
    SQLs = SQLs & "FROM 連絡先テーブル "
    SQLs = SQLs & "ORDER BY 連絡先テーブル.取引先CD; "
    Set RecMain = New ADODB.Recordset
    With RecMain
        .ActiveConnection = cnn
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open Source:=SQLs
    End With
    
    '----- 取引先の情報取得
    Do Until RecMain.EOF
        '----- 取引先毎の情報取得
        SQLs = "SELECT 単価一覧クエリ.取引先CD, 単価一覧クエリ.取引先名, 単価一覧クエリ.品名, 単価一覧クエリ.単価 "
        SQLs = SQLs & " FROM 単価一覧クエリ "
        SQLs = SQLs & "WHERE (((単価一覧クエリ.取引先CD)=""" & RecMain![取引先CD] & """)) "
        SQLs = SQLs & "ORDER BY 単価一覧クエリ.取引先CD, 単価一覧クエリ.品名; "
        Set Rec = New ADODB.Recordset
        With Rec
            .ActiveConnection = cnn
            .CursorType = adOpenStatic
            .LockType = adLockReadOnly
            .Open Source:=SQLs
        End With

        Do Until Rec.EOF
            '----- フィールド値の取得
            'Debug.Print Rec![取引先CD]
            'Debug.Print Rec![取引先名]
            'Debug.Print Rec![品名]
            'Debug.Print Rec![単価]

            '----- 次のレコードへ移動
            Rec.MoveNext
        Loop

        '----- 次のレコードへ移動
        RecMain.MoveNext
    Loop

Test_End:
On Error Resume Next
    '----- 終了処理
    Rec.Close:        Set Rec = Nothing
    RecMain.Close:    Set RecMain = Nothing
    cnn.Close:        Set cnn = Nothing
Exit Sub

'----- エラー処理
Test_Err:
Resume Test_End:
End Sub