【VBA】Excel出力

マスタのCD分、Excel出力

'////　Excel出力
Public Sub ExcelOut(ByVal pMysql As String, ByVal pFilePath As String)
On Error GoTo ErrHnd
 
    Dim qryName As String
    qryName = "Q_Dummy" 'クエリ名の指定
 
    'エクセル出力用クエリ"qryName"の存在を確認。無い場合は作成
    If DCount("*", "[MsysObjects]", "[Name]='" & qryName & "' And [Type]=5") = 0 Then
        Dim qdf As DAO.QueryDef
        Set qdf = CurrentDb.CreateQueryDef(qryName, pMysql) 'クエリの作成
        qdf.Close: Set qdf = Nothing
    End If
     
    'クエリ内のSQLの書き換え
    CurrentDb.QueryDefs(qryName).SQL = pMysql
    'エクセルに出力
    DoCmd.TransferSpreadsheet acExport, 10, qryName, pFilePath, True, ""
    
    MsgBox "出力しました"
     
Exit Sub
 
ErrHnd:
    Select Case Err.Number
     
        Case 2501 'キャンセル処理
            MsgBox "キャンセルしました"
         
        Case 2302 '書き込みエラー
            MsgBox "ファイルの書き込みに失敗しました。"
             
        Case 3061, 3075, 3078, 3131 'SQL構文エラー
            MsgBox "SQL構文エラーです"
         
        Case Else
            MsgBox "ErrorCode:" & Err.Number & Chr(13) & _
                    "ErrorDescription:" & Err.Description
    End Select
End Sub

Private Sub Exp()

    Dim DB As DAO.Database
    Dim RS As DAO.Recordset
    Dim strSQL As String
    Dim FilePath As String
    
    FilePath = CreateObject("WScript.shell").specialfolders("Desktop") & "\"
    
    Set DB = CurrentDb
    strSQL = "SELECT * FROM TM_園マスタ;"
    Set RS = DB.OpenRecordset(strSQL)
    
    'レコードの存在チェック
    If RS.BOF = True And RS.EOF = True Then
        GoTo Finally
    End If
    
    Do Until RS.EOF
        Dim strSQLw As String
        Dim FilePathw As String
        Dim NameCD As Integer
        NameCD = RS![園CD]
        strSQLw = "SELECT * FROM T_kojin WHERE [園CD] = " & NameCD & ";"
        FilePathw = FilePath & NameCD & "_" & RS![園名] & ".xlsx"
        Call ExcelOut(strSQL, FilePathw)
        
        RS.MoveNext
    Loop

Finally:
    RS.Close
    DB.Close
    
    Set RS = Nothing
    Set DB = Nothing

End Sub