エクセルマクロをすこし 2018年8月21日（過去の産物より量を減らして）

ちょっと手直しといった感じですね

基本形は変わっていません。

ただ簡易版といったところですね。

Dimのところに今回は入れていないものが入っているところからも分かるようにメール送信機能を削除しています。

  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

i = 1

Do While i <= SC

Worksheets(i).Copy

Ye = Year(Range("E1")) & "年"

Mo = Month(Range("E1")) & "月"

Da = Day(Range("E1")) & "日"

Filename = Range("B1") & Ye & Mo & Da

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Excelファイル\" & Filename & ".xlsx"

PrintCommunication = False

With ActiveSheet.PageSetup

.PrintArea = Range("B2:Q52").Address

.Zoom = 90

.PaperSize = xlPaperA4

.CenterHorizontally = True

.CenterVertically = True

.LeftMargin = Application.CentimetersToPoints(0.8)

.RightMargin = Application.CentimetersToPoints(0.8)

End With

PrintCommunication = True

ActiveSheet.Name = Range("B1") & Year(Range("E1")) & Month(Range("E1")) & Day(Range("E1"))

ActiveWorkbook.Save

ActiveWorkbook.Close

i = i + 1

Loop

Application.ScreenUpdating = True

ActiveWorkbook.Close

End Sub