Excel VBA | フォルダ内の全 CSV を 1 枚の Excel に統合するテンプレート

Sub SaveMergedAndNotifyWithAttachment()
    Dim wsMaster As Worksheet
    Dim newWb As Workbook
    Dim savePath As String, todayStr As String
    Dim toAddr As String
    
    Set wsMaster = ThisWorkbook.Sheets("Master")
    
    ' Configシートから保存先と宛先を取得
    Dim wsConfig As Worksheet
    Set wsConfig = ThisWorkbook.Sheets("Config")
    savePath = wsConfig.Range("B1").Value   ' 保存先パス
    toAddr = wsConfig.Range("B2").Value     ' 宛先メールアドレス
    
    todayStr = Format(Now, "yyyy-mm-dd HH:NN:SS")
    
    ' 新しいブックを作成
    Set newWb = Workbooks.Add
    wsMaster.UsedRange.Copy newWb.Sheets(1).Cells(1, 1)
    
    Application.DisplayAlerts = False
    newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    newWb.Close SaveChanges:=False
    
    ' 保存完了通知メール（添付付き）
    Call SendMailWithAttachment(toAddr, "[CSV統合完了通知]", _
        "統合結果を保存しました。" & vbCrLf & _
        "保存先: " & savePath & vbCrLf & _
        "日時: " & todayStr, savePath)
    
    MsgBox "統合結果を保存し、通知メール（添付付き）を送信しました。"
End Sub

' Outlookメール送信用（添付付き）
Function SendMailWithAttachment(toAddr As String, subjectText As String, bodyText As String, attachPath As String) As Boolean
    On Error GoTo ErrHandler
    Dim olApp As Object, olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = toAddr
        .Subject = subjectText
        .Body = bodyText
        If Dir(attachPath) <> "" Then .Attachments.Add attachPath
        .Send
    End With
    SendMailWithAttachment = True
    Exit Function
ErrHandler:
    SendMailWithAttachment = False
End Function

Sub SaveMergedAndNotifyWithAttachment()
    Dim wsMaster As Worksheet
    Dim newWb As Workbook
    Dim savePath As String, todayStr As String
    Dim toAddr As String
    
    Set wsMaster = ThisWorkbook.Sheets("Master")
    
    ' Configシートから保存先と宛先を取得
    Dim wsConfig As Worksheet
    Set wsConfig = ThisWorkbook.Sheets("Config")
    savePath = wsConfig.Range("B1").Value   ' 保存先パス
    toAddr = wsConfig.Range("B2").Value     ' 宛先メールアドレス
    
    todayStr = Format(Now, "yyyy-mm-dd HH:NN:SS")
    
    ' 新しいブックを作成
    Set newWb = Workbooks.Add
    wsMaster.UsedRange.Copy newWb.Sheets(1).Cells(1, 1)
    
    Application.DisplayAlerts = False
    newWb.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    newWb.Close SaveChanges:=False
    
    ' 保存完了通知メール（添付付き）
    Call SendMailWithAttachment(toAddr, "[CSV統合完了通知]", _
        "統合結果を保存しました。" & vbCrLf & _
        "保存先: " & savePath & vbCrLf & _
        "日時: " & todayStr, savePath)
    
    MsgBox "統合結果を保存し、通知メール（添付付き）を送信しました。"
End Sub

' Outlookメール送信用（添付付き）
Function SendMailWithAttachment(toAddr As String, subjectText As String, bodyText As String, attachPath As String) As Boolean
    On Error GoTo ErrHandler
    Dim olApp As Object, olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = toAddr
        .Subject = subjectText
        .Body = bodyText
        If Dir(attachPath) <> "" Then .Attachments.Add attachPath
        .Send
    End With
    SendMailWithAttachment = True
    Exit Function
ErrHandler:
    SendMailWithAttachment = False
End Function

Sub ScheduleSaveAndNotify()
    ' 毎日 07:30 に実行
    Application.OnTime TimeValue("07:30:00"), "SaveMergedAndNotifyWithAttachment", , True
End Sub

Sub ScheduleSaveAndNotify()
    ' 毎日 07:30 に実行
    Application.OnTime TimeValue("07:30:00"), "SaveMergedAndNotifyWithAttachment", , True
End Sub