(待望の!!)Excel VBAでのPower Point 自動作成第2弾!!

(待望の!!)Excel VBAでのPower Point 自動作成第2弾!!

色を塗っている部分が今回のポイントとなります！ 

■■■■■■■■■■■■■■■以下ソースコード■■■■■■■■■■■■■■■

Option Explicit

Sub mkPpt()

Dim myWs As Worksheet, numDate As Long, i As Long

Set myWs = ThisWorkbook.Worksheets("報告") '本sheetをセット

numDate = myWs.Cells(16, 2).Value

Dim ppApp As New PowerPoint.Application, ppPrs As PowerPoint.Presentation

Set ppPrs = ppApp.Presentations.Open(ThisWorkbook.Path & "\パワポ.pptx")

Dim ppSld As PowerPoint.Slide, pic As PowerPoint.Shape

ppApp.Visible = True

'■■■■■■1ページ目(サマリー)■■■■■■

Set ppSld = ppPrs.Slides(1) '1ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.textRange.Text = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.textRange.Text = _

    myWs.Cells(14, 3) & myWs.Cells(14, 4) & "、" & myWs.Cells(15, 3) & myWs.Cells(15, 4) & vbLf & _

    myWs.Cells(14, 10) & myWs.Cells(14, 11) & "、" & myWs.Cells(15, 10) & myWs.Cells(15, 11) & vbLf & _

    myWs.Cells(14, 17) & myWs.Cells(14, 18) & "、" & myWs.Cells(15, 17) & myWs.Cells(15, 18)

Call changeSize(ppSld.Shapes("TextBox1").TextFrame.textRange, "支店", 18)

For i = 4 To 18 Step 7

    Select Case Right(myWs.Cells(15, i), 2)

    Case "増加"

        Call changeColor(ppSld.Shapes("TextBox1").TextFrame.textRange, myWs.Cells(15, i), 0, 0, 255) '青

    Case "減少"

        Call changeColor(ppSld.Shapes("TextBox1").TextFrame.textRange, myWs.Cells(15, i), 255, 0, 0) '赤

    Case Else

        Call changeColor(ppSld.Shapes("TextBox1").TextFrame.textRange, myWs.Cells(15, i), 127, 127, 127) 'グレイ

    End Select

Next

Dim cht As PowerPoint.Chart, lastRow As Long

Set cht = ppSld.Shapes("グラフ").Chart

cht.ChartData.Activate

With cht.ChartData.Workbook.Worksheets(1)

    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1

    .Cells(lastRow, 1) = Format(Date, "～m/d")

    .Cells(lastRow, 2) = myWs.Cells(13, 4)

    .Cells(lastRow, 3) = myWs.Cells(13, 11)

    .Cells(lastRow, 4) = myWs.Cells(13, 18)

End With

cht.ChartData.Workbook.Close

'■■■■■■2ページ目■■■■■■

Set ppSld = ppPrs.Slides(2) '2ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.textRange.Text = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.textRange.Text = myWs.Cells(14, 4) & " " & myWs.Cells(15, 4)

Call changeColor(ppSld.Shapes("TextBox1").TextFrame.textRange, "無し", 255, 0, 0)

Call changeSize(ppSld.Shapes("TextBox1").TextFrame.textRange, "無し", 9)

Range(myWs.Cells(1, 1), myWs.Cells(13, 6)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■3ページ目■■■■■■

Set ppSld = ppPrs.Slides(3) '3ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.textRange.Text _

                        = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.textRange.Text = myWs.Cells(14, 11) & " " & myWs.Cells(15, 11)

Range(myWs.Cells(1, 8), myWs.Cells(13, 13)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■4ページ目■■■■■■

Set ppSld = ppPrs.Slides(4) '4ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.textRange.Text _

                        = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.textRange.Text = myWs.Cells(14, 18) & " " & myWs.Cells(15, 18)

Range(myWs.Cells(1, 15), myWs.Cells(13, 20)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■終了手続き■■■■■■

Application.DisplayAlerts = False

ppPrs.SaveAs ThisWorkbook.Path & "\パワポ_" & Format(numDate, "yyyymmdd") & ".pptx"

Application.DisplayAlerts = True

'ppApp.Quit

MsgBox "そいや、" & vbLf & "幅：" & ppPrs.PageSetup.SlideWidth _

& vbLf & "高さ：" & ppPrs.PageSetup.SlideHeight & vbLf & "です!", vbInformation

Application.CutCopyMode = False

End Sub

Sub changeColor(ChangedTextRange As Variant, strTarget As String, R As Byte, G As Byte, B As Byte)

Dim numStart As Long, numLength As Long, numFindStart As Long

numLength = Len(strTarget)

numFindStart = 1

Do While InStr(numFindStart, ChangedTextRange.Text, strTarget) <> 0

    numStart = InStr(numFindStart, ChangedTextRange.Text, strTarget)

    ChangedTextRange.Characters(Start:=numStart, Length:=numLength).Font.Color = RGB(R, G, B)

    numFindStart = numStart + 1

Loop

End Sub

Sub changeSize(ChangedTextRange As Variant, strTarget As String, numSize As Double)

Dim numStart As Long, numLength As Long, numFindStart As Long

numLength = Len(strTarget)

numFindStart = 1

Do While InStr(numFindStart, ChangedTextRange.Text, strTarget) <> 0

    numStart = InStr(numFindStart, ChangedTextRange.Text, strTarget)

    ChangedTextRange.Characters(Start:=numStart, Length:=numLength).Font.Size = numSize

    numFindStart = numStart + 1

Loop

End Sub