Public Sub AddPictures()

    Dim ppApp As PowerPoint.Application

    Set ppApp = New PowerPoint.Application

    Dim Pre As PowerPoint.Presentation

    Dim NewSld As PowerPoint.Slide

    Dim tShp As PowerPoint.Shape

    Dim pShp As PowerPoint.Shape

    Const PPT_NAME  As String = "图片.ppt"

    Dim pptPath As String

    pptPath = ThisWorkbook.Path & "\" & PPT_NAME

    Set Pre = ppApp.Presentations.Add(msoTrue)

    Pre.SaveAs pptPath

    Dim PicIndex As Long

    Dim SldIndex As Long

    SldIndex = 0

    With ThisWorkbook.Sheets("数据")

        '预先排序

        CustomSort .UsedRange

        '逐个类别 逐个单位

        endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row

        For i = 2 To endrow

            If .Cells(i, "G").Text <> .Cells(i - 1, "G").Text Then

                '若类别不同

                SldIndex = SldIndex + 1

                PicIndex = 1

                Debug.Print i; "插入新幻灯片"; SldIndex

                Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)

                NewSld.Name = SldIndex

                Debug.Print i; "插入图片"; PicIndex

                Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)

                Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text

                Set tShp = InsertTextBox(NewSld, pShp, Text)

            Else

                '若类别相同

                If .Cells(i, "D").Text <> .Cells(i - 1, "D").Text Then

                    '若单位不同

                    PicIndex = 1

                    SldIndex = SldIndex + 1

                    Debug.Print i; "插入新幻灯片"; SldIndex

                    Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)

                    NewSld.Name = SldIndex

                    Debug.Print i; "插入图片1"

                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)

                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text

                    Set tShp = InsertTextBox(NewSld, pShp, Text)

                Else

                    '若单位相同

                    PicIndex = PicIndex + 1

                    PicIndex = (PicIndex - 1) Mod 4 + 1

                    If PicIndex = 1 Then  '当同类超过一页幻灯片时

                    SldIndex = SldIndex + 1

                    Debug.Print i; ">5插入新幻灯片"; SldIndex

                    Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)

                    NewSld.Name = SldIndex

                    Debug.Print i; ">5同类同单位插入图片"; PicIndex

                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)

                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text

                    Set tShp = InsertTextBox(NewSld, pShp, Text)

                Else

                    Debug.Print i; "同类同单位插入图片"; PicIndex

                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)

                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text

                    Set tShp = InsertTextBox(NewSld, pShp, Text)

                End If

            End If

        End If

    Next i

End With

Pre.Save

Pre.Close

ppApp.Quit

Set ppApp = Nothing

End Sub

Private Sub CustomSort(ByVal RngWithTitle As Range)

    With RngWithTitle

        .Sort _

        Key1:=RngWithTitle.Cells(1, 7), Order1:=xlAscending, _

        Key2:=RngWithTitle.Cells(1, 4), Order2:=xlAscending, _

              Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin

    End With

End Sub

Private Function InsertPicture(ByVal Pre As PowerPoint.Presentation, ByVal NewSld As PowerPoint.Slide, _

                                        ByVal ImagePath As String, ByVal Pos As Long) As PowerPoint.Shape

    Dim Shp As PowerPoint.Shape

    Set Shp = NewSld.Shapes.AddPicture(ImagePath, msoFalse, msoTrue, CLeft(Pre, Pos), CTop(Pre, Pos), CWidth(Pre, Pos), CHeight(Pre, Pos))

    Set InsertPicture = Shp

    Set Shp = Nothing

End Function

Private Function CLeft(ByVal Pre As PowerPoint.Presentation, ByVal Pos As Long, Optional JG As Long = 10) As Double

    Dim SW As Double

    Dim SH As Double

    SW = Pre.PageSetup.SlideWidth

    SH = Pre.PageSetup.SlideHeight

        Select Case Pos

        Case 1, 3

        CLeft = JG

        Case 2, 4

        CLeft = JG * 3 + SW / 2

        End Select

End Function

Private Function CTop(ByVal Pre As PowerPoint.Presentation, ByVal Pos As Long, Optional JG As Long = 10) As Double

    Dim SW As Double

    Dim SH As Double

    SW = Pre.PageSetup.SlideWidth

    SH = Pre.PageSetup.SlideHeight

        Select Case Pos

        Case 1, 2

        CTop = JG

        Case 3, 4

        CTop = JG * 3 + SH / 2

        End Select

End Function

Private Function CWidth(ByVal Pre As Presentation, Optional JG As Long = 10) As Double

    Dim SW As Double

    Dim SH As Double

    SW = Pre.PageSetup.SlideWidth

    SH = Pre.PageSetup.SlideHeight

    CWidth = (SW - 4 * JG) / 2 - 30

End Function

Private Function CHeight(ByVal Pre As Presentation, Optional JG As Long = 10) As Double

    Dim SW As Double

    Dim SH As Double

    SW = Pre.PageSetup.SlideWidth

    SH = Pre.PageSetup.SlideHeight

    CHeight = (SH - 4 * JG) / 2 - 100

End Function

Private Function InsertTextBox(ByVal NewSld As PowerPoint.Slide, ByVal pShp As PowerPoint.Shape, ByVal Text As String) As PowerPoint.Shape

    Dim Shp As PowerPoint.Shape

    Dim Pos As Long

    Dim Tr As PowerPoint.TextRange

    With NewSld

        Set Shp = .Shapes.AddTextBox(msoTextOrientationHorizontal, pShp.Left, pShp.Top + pShp.Height, pShp.Width, 50)

        With Shp

            .TextFrame.WordWrap = msoTrue

            With .TextFrame.TextRange

                With .ParagraphFormat

                    .LineRuleWithin = msoTrue

                    .SpaceWithin = 1

                    .LineRuleBefore = msoTrue

                    .SpaceBefore = 0.5

                    .LineRuleAfter = msoTrue

                    .SpaceAfter = 0

                End With

                myText = Text

                .Text = myText

                Pos = InStr(myText, Chr(13))

                Set Tr = .Characters(1, Pos)

                With Tr

                    .Font.Size = 14

                    .Font.Color.RGB = RGB(Red:=255, Green:=51, Blue:=255)

                End With

                Set Tr = .Characters(Pos + 1, Len(myText) - Pos)

                With Tr

                    .Font.Size = 18

                    .Font.Color.RGB = RGB(Red:=255, Green:=51, Blue:=0)

                End With

            End With

        End With

    End With

    Set InsertTextBox = Shp

    Set Shp = Nothing

End Function