Я создал программу для создания и отправки квитанций. Я справился с этим, посмотрев онлайн.
Это работает, но я бы хотел отправить квитанции, когда условие выполнено.
cfws.Range("N" & I).Value = "no"
Должен ли я запускать If после создания файлов pdf или после создания объекта Outlook?
Я пробовал несколько вещей, но в большинстве моих попыток я получаю ошибку
Далее без For.
Option Explicit
Sub CopyToTemplate()
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim lastrow As Long
Dim I As Long
Dim fileloc As String
Dim filename As String
Dim Fname As String
Dim OutlApp As Object
Dim IsCreated As Boolean
Dim Count As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set cfws = Worksheets("Monthly data")
Set ctws = Worksheets("Template")
Count = 0
lastrow = cfws.Cells(cfws.Rows.Count, "B").End(xlUp).Row
fileloc = "C:\Users\dave.i\Documents\Project\Receipts\"
'This creates the receipt
For I = 2 To lastrow
filename = "DCN #" & cfws.Range("A" & I).Value & " receipt"
ctws.Range("C41").Value = "Sub ID " & cfws.Range("A" & I).Value
ctws.Range("D14").Value = cfws.Range("B" & I).Value
ctws.Range("C43").Value = cfws.Range("B" & I).Value
ctws.Range("D13").Value = cfws.Range("C" & I).Value
ctws.Range("C42").Value = cfws.Range("C" & I).Value
ctws.Range("C44").Value = cfws.Range("D" & I).Value
ctws.Range("C45").Value = cfws.Range("E" & I).Value
ctws.Range("D15").Value = cfws.Range("D" & I).Value & ", " & cfws.Range("E" & I).Value
ctws.Range("I45").Value = cfws.Range("F" & I).Value
ctws.Range("I46").Value = cfws.Range("G" & I).Value
ctws.Range("I47").Value = cfws.Range("H" & I).Value
ctws.Range("C45").Value = cfws.Range("E" & I).Value
ctws.Range("B51").Value = cfws.Range("I" & I).Value
ctws.Range("H50").Value = cfws.Range("J" & I).Value
ctws.Range("B56").Value = "Charged to " & cfws.Range("K" & I).Value & " on"
ctws.Range("B57").Value = cfws.Range("L" & I).Value
'This names the receipt and creates it
Fname = fileloc & filename & ".pdf"
With ctws
.ExportAsFixedFormat Type:=xlTypePDF, filename:=Fname
End With
'Time to send the receipts
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
**'Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Daily Commercial News receipt #" & cfws.Range("A" & I).Value
.To = cfws.Range("M" & I).Value
'.CC = "..." ' <-- Put email of 'copy to' recipient here
.Body = "Hello," & vbLf & vbLf _
& "Attached is the receipt for your monthly subscription." & vbLf & vbLf _
& "Please do note hesitate to contact us should you have any other concerns." & vbLf & vbLf _
& "Best Regards," & vbLf _
& Application.UserName & vbLf _
& "Customer Service representative" & vbLf _
& vbLf & vbLf
.Attachments.Add Fname
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail to " & cfws.Range("M" & I).Value & " was not sent", vbExclamation
Else
Count = Count + 1
End If
On Error GoTo 0**
End With
Next I
'Sends the number of emails sent
MsgBox Count & " E-mails successfully sent", vbInformation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub