求大神将EXCEL表中文字及图片导出生成对应PPT文件-或用其它方式

13858808623

1.如上EXCEL表，将表中的隐患描述、整改人、整改完成日期内容，照片等，通过VB代码按钮“导出生成PPT文件“按钮，即可自动生成PPT文件。
2.以上为PPT列举4行内容，实际可能不只是4行，实际可能50至100行内容。相应生成50至100页PPT内容；

3.PPT文件样式及对应EXELE表中内容，照片等，生成PPT文件后内容如下图：
4.如下图格式上方文字内容格式编写有困难，PPT上方的文字描述，也可全用表格一行多列展示。
求大神下载附件帮其解决，谢谢



求大神解决，谢谢.

Jday1218

Sub ExportToPPT()
    Dim ppt As Object
    Dim slide As Object
    Dim shape As Object
    Dim title As String
    Dim i As Long
    Dim j As Long
   
    ' 获取需要导出的标题
    title = InputBox("请输入需要导出的标题", "导出 PPT")
   
    ' 如果没有输入标题，退出程序
    If Len(title) = 0 Then Exit Sub
   
    ' 新建 PPT 文件
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Add
   
    ' 遍历 Excel 表格中的每个单元格，查找标题
    For i = 1 To ActiveSheet.Cells.SpecialCells(xlLastCell).Row
        For j = 1 To ActiveSheet.Cells.SpecialCells(xlLastCell).Column
            If ActiveSheet.Cells(i, j).Value = title Then
                ' 新建 PPT 页面，并将标题复制到页面中
                Set slide = ppt.ActivePresentation.Slides.Add(ppt.ActivePresentation.Slides.Count + 1, 11)
                Set shape = slide.Shapes.AddTextEffect(msoTextEffect1, title, "Arial", 36)
                shape.Top = 50
                shape.Left = 50
                Exit For
            End If
        Next j
    Next i
   
    ' 关闭 PPT 文件
    Set slide = Nothing
    Set ppt = Nothing
End Sub

Jday1218

Sub ExportToPPT()
    Dim pptApp As PowerPoint.Application
    Dim pptPresentation As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide
    Dim slideIndex As Integer
    Dim titleText As String
    Dim titleRange As Range
   
    ' 获取 PowerPoint 应用程序对象
    Set pptApp = New PowerPoint.Application
   
    ' 创建新的 PowerPoint 文件
    Set pptPresentation = pptApp.Presentations.Add
   
    ' 设置 PPT 文件属性
    pptPresentation.PageSetup.SlideSize = ppSlideSizeOnScreen16x9
    pptPresentation.PageSetup.SlideOrientation = msoOrientationHorizontal
   
    ' 获取需要导出的标题
    titleText = "这是一个标题"
    Set titleRange = Range("A1:F1").Find(titleText)
   
    ' 如果找到了指定的标题，导出为 PPT 文件
    If Not titleRange Is Nothing Then
        ' 在 PPT 文件中创建新的幻灯片
        Set pptSlide = pptPresentation.Slides.Add(1, ppLayoutBlank)
        
        ' 将指定单元格区域的内容复制到新的幻灯片中
        titleRange.Copy
        pptSlide.Shapes.Paste
        
        ' 设置新的幻灯片布局和样式
        pptSlide.Layout = ppLayoutTitle
        pptSlide.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
        pptSlide.Background.Fill.Transparency = 0#
        
        ' 将幻灯片输出为 PPT 文件
        slideIndex = 1
        pptPresentation.SaveAs "C:\Users\username\Desktop\Exported.pptx"
        pptPresentation.Close
        pptApp.Quit
    Else
        MsgBox "找不到指定的标题！", vbExclamation, "提示"
    End If
End Sub

13858808623

请教高手，运行代码出错了，如何解决，谢谢