试试看吧

Option Explicit
Sub CreatePresentation()
    Dim pptApp, pptPresentation
    Dim pptSlide, pptShape
    Dim c As Range, i As Integer
    const EXCEL_DATA_RANGE = "A1:A3" ' Update as needed
    Const msoTextOrientationHorizontal = 1
    Const ppLayoutText = 2
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
        If pptApp Is Nothing Then Exit Sub
    End If
    pptApp.Visible = True
    ' Add a presentation
    Set pptPresentation = pptApp.Presentations.Add
    ' Add a slide
    Set pptSlide = pptPresentation.Slides.Add(1, ppLayoutText)
    i = 1
    For Each c In Range(EXCEL_DATA_RANGE)
        ' Add a shape, update location and size as needed
        Set pptShape = pptSlide.Shapes.AddShape(Type:=msoTextOrientationHorizontal, _
            Left:=100, Top:=50 + 60 * i, Width:=100, Height:=50)
        ' Update text on shape
        pptShape.TextFrame.TextRange.Text = c.Value
        i = i + 1
    Next c
    ' Savt ppt file
    ' pptPresentation.SaveAs "D:\Excel2PPT.pptx"
End Sub