簡単なexcelのVBAの練習 2018年9月5日 IFを使って処理を考えてみました。

処理を考えてみました。

昨日の段階ではここまで。IFを使って文字処理やフォルダー作成を試みていますけれど、目的としてはいかに年月日を表示する際文字数を統一するか、つまり、月日が1桁のとき0をつけて統一させるかが今回の一番の課題でした。他のIF内は外のところのコピーですけれど、一つのIFのところにIFを入れての処理と考えてみてやってみたらうまく実行ができました。

とりあえずは不満はあるももののある程度のところはできたので良しとします。

うまい人ならもっと短いコードで書き上げるのでしょうが私はこれでしょりしていきたいです。

3種類あります

Sub inunubuu(ByVal control As IRibbonControl)

Application.ScreenUpdating = False

years = Year(Range("H6"))

months = Month(Range("H6"))

dayss = Day(Range("H6"))

fullday = years & months & dayss

secell = Range("B3")

SavDir0 = "C:\wewe\werwer\"

hidut = secell

years2 = Year(Range("BU6"))

months2 = Month(Range("BU6"))

dayss2 = Day(Range("BU6"))

If months < 10 Then

        yearmonth = years & "0" & months

    Else

       yearmonth = years & months

End If

If months2 < 10 Then

        yearmonth2 = years2 & "0" & months2

    Else

       yearmonth2 = years2 & months2

End If

Dim FolderName As String   feef

    FolderName = SavDir0 & yearmonth

    If Dir(FolderName, vbDirectory) = "" Then

        MkDir FolderName

    Else

    End If

SavDir = FolderName & "\"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SavDir + hidut & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

  ActiveSheet.Copy

    Application.PrintCommunication = True

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .PrintQuality = 600

        .PaperSize = xlPaperA3

        .FitToPagesWide = 1

    End With

    Application.PrintCommunication = True

ActiveSheet.Name = yearmonth & " -" & yearmonth2

ActiveWorkbook.SaveAs Filename:=SavDir + hidut _

        , FileFormat:=xlWorkbookDefault _

         , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

         CreateBackup:=False

ActiveWorkbook.Close

Dim toaddress, ccaddress, bccaddress As String

Dim subject, mailBody, credit As String '

Dim outlookObj As Outlook.Application

Dim mailItemObj As Outlook.mailItem

toaddress = "regrergr@sreh4h.com"

subject = "【febrr】　" & secell

mailBody = secell & "です。" & vbCrLf & "gergree"

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, attached2 As String

Dim myattachments As Outlook.Attachments

Set myattachments = mailItemObj.Attachments

attached = SavDir & hidut & ".pdf"

attached2 = SavDir & hidut & ".xlsx"

myattachments.Add attached

myattachments.Add attached2

'mailItemObj.Save

'mailItemObj.Display

mailItemObj.Send

Set outlookObj = Nothing

Set mailItemObj = Nothing

    ActiveWorkbook.Close

Application.ScreenUpdating = True

ActiveWorkbook.Saved = True

    ActiveWorkbook.Close

End Sub

Sub gregergrtg(ByVal control As IRibbonControl)

Application.ScreenUpdating = False

SavDir0 = "C:\dfew\fge\"

years = Year(Range("P8"))

months = Month(Range("P8"))

dayss10 = Day(Range("P8"))

years2 = Year(Range("AI8"))

months2 = Month(Range("AI8"))

dayss20 = Day(Range("AI8"))

years3 = Year(Range("H8"))

months3 = Month(Range("H8"))

dayss30 = Day(Range("H8"))

hidut = secell

If months < 10 Then

        yearmonth = years & "0" & months

    Else

       yearmonth = years & months

End If

If months2 < 10 Then

        yearmonth2 = years2 & "0" & months2

    Else

       yearmonth2 = years2 & months2

End If

If months3 < 10 Then

        yearmonth3 = years2 & "0" & months3

    Else

       yearmonth3 = years2 & months3

End If

If dayss10 < 10 Then

        dayss1 = "0" & dayss10

    Else

       dayss1 = years & dayss10

End If

If dayss20 < 10 Then

        dayss2 = "0" & dayss20

    Else

       dayss2 = years & dayss20

End If

If dayss10 < 10 Then

        dayss3 = "0" & dayss30

    Else

       dayss3 = years & dayss30

End If

Dim FolderName As String   '

    FolderName = SavDir0 & yearmonth

    If Dir(FolderName, vbDirectory) = "" Then 

        MkDir FolderName

    Else

    End If

SavDir = FolderName & "\"

FilNam = "4dgerwq　" & yearmonth3 & dayss3 & "-" & yearmonth3 & dayss3

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SavDir + FilNam & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

  ActiveSheet.Copy

    Application.PrintCommunication = True

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0)

        .RightMargin = Application.InchesToPoints(0)

        .TopMargin = Application.InchesToPoints(0.590551181102362)

        .BottomMargin = Application.InchesToPoints(0.196850393700787)

        .HeaderMargin = Application.InchesToPoints(0.393700787401575)

        .FooterMargin = Application.InchesToPoints(0.196850393700787)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintNoComments

        .PrintQuality = 600

        .CenterHorizontally = True

        .CenterVertically = True

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA3

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = False

        .EvenPage.LeftHeader.Text = ""

        .EvenPage.CenterHeader.Text = ""

        .EvenPage.RightHeader.Text = ""

        .EvenPage.LeftFooter.Text = ""

        .EvenPage.CenterFooter.Text = ""

        .EvenPage.RightFooter.Text = ""

        .FirstPage.LeftHeader.Text = ""

        .FirstPage.CenterHeader.Text = ""

        .FirstPage.RightHeader.Text = ""

        .FirstPage.LeftFooter.Text = ""

        .FirstPage.CenterFooter.Text = ""

        .FirstPage.RightFooter.Text = ""

    End With

ActiveSheet.Name = "rtrt" & yearmonth1 & dayss1

ActiveWorkbook.SaveAs Filename:=SavDir + FilNam _

        , FileFormat:=xlWorkbookDefault _

         , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

         CreateBackup:=False

ActiveWorkbook.Close

Dim toaddress, ccaddress, bccaddress As String

Dim subject, mailBody, credit As String '

Dim outlookObj As Outlook.Application

Dim mailItemObj As Outlook.mailItem

toaddress = "odrtt4t@sdefe.com"

subject = "【rrre】 " & Range("B2")

mailBody = Range("B2") & "です。" & vbCrLf & "werert43"

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, attached2 As String

Dim myattachments As Outlook.Attachments

Set myattachments = mailItemObj.Attachments

attached = SavDir & FilNam & ".pdf"

attached2 = SavDir & FilNam & ".xlsx"

myattachments.Add attached

myattachments.Add attached2

'mailItemObj.Save

mailItemObj.Display

'mailItemObj.Send

Set outlookObj = Nothing

Set mailItemObj = Nothing

    ActiveWorkbook.Close

    Application.PrintCommunication = True

Application.ScreenUpdating = True

ActiveWorkbook.Save

ActiveWorkbook.Close

End Sub

Sub dfewewe(ByVal control As IRibbonControl)

Application.ScreenUpdating = False

Dim SavDir, FolderName, SavDir0 As String

Dim hidut, dayd2 As String

Dim days As Date

Dim years, monthd, dayd, SheNem As Long

SavDir = "c:\cccc\dee\"

years = Year(Range("J4"))

monthd = Month(Range("J4"))

dayd = Day(Range("J4"))

If monthd < 10 Then

        month0 = years2 & "0" & monthd

    Else

       month0 = monthd

End If

If dayd < 10 Then

        dayss1 = "0" & dayd

    Else

       dayss1 = dayd

End If

SheNem = years & month0 & dayss1

dayd2 = years & "年" & month0 & "月" & dayss1 & "日"

hidut = "ewerwer  " & dayd2

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SavDir & hidut & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    Dim sp As Shape

    Dim l As Double

    Dim t As Double

    For Each sp In ActiveSheet.Shapes

        If sp.Type = msoPicture Then

            l = sp.Left

            t = sp.Top

            sp.Select

            Selection.Cut

            ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

            DoEvents

            With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)

                .Left = l

                .Top = t

            End With

        End If

    Next

  ActiveSheet.Copy

    Application.PrintCommunication = True

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftMargin = Application.InchesToPoints(0.511811023622047)

        .RightMargin = Application.InchesToPoints(0.511811023622047)

        .TopMargin = Application.InchesToPoints(0.551181102362205)

        .BottomMargin = Application.InchesToPoints(0.551181102362205)

        .HeaderMargin = Application.InchesToPoints(0.31496062992126)

        .FooterMargin = Application.InchesToPoints(0.31496062992126)

    End With

If Range("I2") = "efewfwe" Then

  SavDir0 = "C:\Users\\cccc\Desktop\テスト2\"

    FolderName = SavDir0 & years & "年" & month0 & "月"

    If Dir(FolderName, vbDirectory) = "" Then  

        MkDir FolderName

           FolderName1 = SavDir0 & years & "年" & month0 & "月\"

    Else

      End If

ElseIf Range("I2") = "gvwerwege" Then

SavDir0 = "C:\Users\\cccc7\Desktop\テスト1\"

    FolderName = SavDir0 & years & "年" & month0 & "月"

    If Dir(FolderName, vbDirectory) = "" Then  

        MkDir FolderName

           FolderName1 = SavDir0 & years & "年" & month0 & "月\"

    Else

      End If

Else

FolderName1 = "C:\Users\cccc\Desktop\テスト3\"

End If

ActiveSheet.Name = SheNem

ActiveWorkbook.SaveAs Filename:=FolderName1 & hidut _

        , FileFormat:=xlWorkbookDefault _

         , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

         CreateBackup:=False

ActiveWorkbook.Close

Dim toaddress, ccaddress, bccaddress As String

Dim subject, mailBody, credit As String '

Dim outlookObj As Outlook.Application

Dim mailItemObj As Outlook.mailItem

Application.ScreenUpdating = False

toaddress = "abcd@efgh.com"

subject = hidut & "　" & Range("I2") & "aaaaa"

mailBody = dayd2 & "(" & Range("I2") & ")ccccccc。" & vbCrLf & "ddddd。" & vbCrLf & vbCrLf & "ssssss"

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, attached2 As String

Dim myattachments As Outlook.Attachments

Set myattachments = mailItemObj.Attachments

attached = SavDir & hidut & ".pdf"

attached2 = FolderName1 & hidut & ".xlsx"

myattachments.Add attached

myattachments.Add attached2

'mailItemObj.Save

mailItemObj.Display

'mailItemObj.Send

Set outlookObj = Nothing

Set mailItemObj = Nothing

    ActiveWorkbook.Close

Application.PrintCommunication = True

Application.ScreenUpdating = False

ActiveWorkbook.Saved = True

    ActiveWorkbook.Close

End Sub