エクセルマクロをすこし 2018年8月13日 ある程度めどが立ちました

ようやく、メール処理のところまでできたのですが、これからは一覧表化に挑戦をしていきたいと思います。
とりあえずは、添付ファイルの処理も確認できたので出来高70ということにしておきたいです。
実践を考えるとまだ出来高は４０弱ですがこの休み中にやろうと思っていたことはほぼ終わりました。
これからはゆっくりと夏休みを満喫したいと思います。

Sub yy()
Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String
Dim subject, mailBody, credit As String '
Dim outlookObj As Outlook.Application
Dim mailItemObj As Outlook.mailItem
Dim i, SC As Long
Application.ScreenUpdating = False
SC = ActiveWorkbook.Sheets.Count
Ye = Year(Date) & "年"
Mo = Month(Date) & "月"
Da = Day(Date) & "日"
i = 1
Do While i <= SC
Worksheets(i).Copy
PrintCommunication = False
With ActiveSheet.PageSetup
.PrintArea = Range("A1:G29").Address
.Zoom = 80
.PaperSize = xlPaperA4
.CenterHorizontally = True
.CenterVertically = True
.LeftMargin = Application.CentimetersToPoints(0.8)
.RightMargin = Application.CentimetersToPoints(0.8)
End With
PrintCommunication = True
ActiveSheet.Name = Range("J5") & Year(Date) & Month(Date) & Day(Date)
Filename = Range("J5") & Ye & Mo & Da
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Filename & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx"
toaddress = "masaki@shiina.me"
subject = Range("J5") & Year(Date) & Month(Date) & Day(Date) & "zzzzzzzzzzzzzzzz"
mailBody = Year(Date) & Month(Date) & Day(Date) & "の" & Range("J5") & "qqqqqqqqq" & vbCrLf & "sassa。"
Set outlookObj = CreateObject("Outlook.Application")
Set mailItemObj = outlookObj.CreateItem(olMailItem)
mailItemObj.BodyFormat = 3
mailItemObj.To = toaddress
mailItemObj.cc = ccaddress
mailItemObj.BCC = bccaddress
mailItemObj.subject = subject
mailItemObj.Body = mailBody & vbCrLf & credit
Dim attached As String
Dim myattachments As Outlook.Attachments
Set myattachments = mailItemObj.Attachments
attached = ThisWorkbook.Path & "\" & Filename & ".pdf"
myattachments.Add attached
mailItemObj.Save
mailItemObj.Display
mailItemObj.Send
Set outlookObj = Nothing
Set mailItemObj = Nothing
　　ActiveWorkbook.Close
i = i + 1
Loop
Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub