Excel 数据写入 PowerPoint 表格与文本框（涨跌幅颜色自动处理）

教程：

本教程展示如何用 VBA 将 Excel 数据写入 PowerPoint 中：

两张表格（涨跌幅表格）
两页文本框（按名称匹配）
自动根据涨跌幅设置颜色（红/绿/黑）

1️⃣ Excel 数据结构要求

表格数据

区域	列	内容说明
Z1:AE1	标题行	表格标题，保留原色
Z2:AE9	数据行（表1）	小麦相关涨跌幅数据
Z12:AE22	数据行（表2）	小麦相关涨跌幅数据

涨跌幅列 必须在 AE 列（百分比数值，用于颜色判断）

文本框数据

页码	Excel列	内容
第1页	AF2:AF9	PPT 文本框名称
第1页	AG2:AG9	PPT 文本框内容
第1页	AE2:AE9	涨跌幅（用于颜色判断）
第2页	AF13:AF22	PPT 文本框名称
第2页	AG13:AG22	PPT 文本框内容
第2页	AE13:AE22	涨跌幅（颜色）

说明：文本框名称必须与 PPT 中文本框 Name 属性一致，否则会在 Immediate 窗口打印"未找到文本框"。

2️⃣ 功能说明

表格写入
- 表格标题保持 Excel 原字体样式
- 表格数据根据 AE 列涨跌幅自动设置字体颜色：
  - 红色：上涨
  - 绿色：下跌
  - 黑色：持平
文本框写入
- 按 Excel AF 列匹配 PPT 文本框名称
- 写入内容（AG列）
- 根据 AE 列设置颜色（红/绿/黑）
支持两页 PPT
- 第1页表格 + 第1页文本框
- 第2页表格 + 第2页文本框

3️⃣ VBA 代码（完整模块）

vba 复制代码

Option Explicit

Sub 两个涨跌幅表_及文本框一次完成()

    '================ Excel =================
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks("0 一周大屏数据(宏）.xlsx")
    Set ws = wb.Worksheets("每周简讯大屏 ")

    '================ PPT ===================
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pptTable As Object
    Dim shp As Object
    Dim pptPath As String

    pptPath = "F:\OneDrive\小麦大数据中心\工作\其他工作\0 数据报送\一周粮讯\每周大屏\每周简讯大屏_发布\0119\0 每周简讯大屏0119-1.pptx"

    ' 启动 PowerPoint
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    On Error GoTo 0

    Set pptPres = pptApp.Presentations.Open(pptPath)

    '================== 表一 =================
    Set pptSlide = pptPres.Slides(1)
    Set pptTable = Nothing
    For Each shp In pptSlide.Shapes
        If shp.HasTable And shp.Name = "X_涨跌幅" Then
            Set pptTable = shp.Table
            Exit For
        End If
    Next shp

    If pptTable Is Nothing Then
        MsgBox "未找到 X_涨跌幅", vbCritical
        Exit Sub
    End If

    Call 写入表(ws, pptTable, 1, 9, 1)

    '================ 第1页文本框 =================
    Call 写入文本框页(ws, pptPres.Slides(1), 2, 9)

    '================== 表二 =================
    Set pptSlide = pptPres.Slides(2)
    Set pptTable = Nothing
    For Each shp In pptSlide.Shapes
        If shp.HasTable And shp.Name = "Y_涨跌幅" Then
            Set pptTable = shp.Table
            Exit For
        End If
    Next shp

    If pptTable Is Nothing Then
        MsgBox "未找到 Y_涨跌幅", vbCritical
        Exit Sub
    End If

    Call 写入表(ws, pptTable, 12, 22, 12)

    '================ 第2页文本框 =================
    Call 写入文本框页(ws, pptPres.Slides(2), 13, 22)

    MsgBox "两个表和两页文本框已全部完成", vbInformation

End Sub

'================ 写入表格 =================
Sub 写入表(ws As Worksheet, pptTable As Object, startRow As Long, endRow As Long, headerRow As Long)
    Dim r As Long, c As Long
    Dim pptRow As Long
    Dim rawVal As String, v As Double, fontColor As Long

    ' 标题
    pptRow = 1
    For c = 1 To 6
        pptTable.Cell(pptRow, c).Shape.TextFrame.TextRange.Text = ws.Cells(headerRow, 25 + c).Text
    Next c

    ' 数据
    pptRow = 2
    For r = startRow + 1 To endRow
        rawVal = ws.Range("AE" & r).Text
        rawVal = Replace(rawVal, "%", "")
        If IsNumeric(rawVal) Then v = CDbl(rawVal) Else v = 0

        Select Case True
            Case v > 0: fontColor = RGB(255, 0, 0)
            Case v < 0: fontColor = RGB(0, 176, 80)
            Case Else: fontColor = RGB(255, 255, 255)
        End Select

        For c = 1 To 6
            With pptTable.Cell(pptRow, c).Shape.TextFrame.TextRange
                .Text = ws.Cells(r, 25 + c).Text
                .Font.Name = ws.Cells(r, 25 + c).Font.Name
                .Font.Size = ws.Cells(r, 25 + c).Font.Size
                .Font.Bold = ws.Cells(r, 25 + c).Font.Bold
                .Font.Color.RGB = fontColor
            End With
        Next c

        pptRow = pptRow + 1
    Next r
End Sub

'================ 按名称写入文本框 =================
Sub 写入文本框页(ws As Worksheet, pptSlide As Object, startRow As Long, endRow As Long)
    Dim i As Long
    Dim shp As Object
    Dim txtVal As String, txtName As String
    Dim rawVal As String, v As Double, fontColor As Long

    For i = startRow To endRow
        txtName = ws.Cells(i, 32).Text   ' AF列 = PPT文本框名称
        txtVal = ws.Cells(i, 33).Text    ' AG列 = 内容
        rawVal = ws.Cells(i, 31).Text    ' AE列 = 涨跌幅
        rawVal = Replace(rawVal, "%", "")
        If IsNumeric(rawVal) Then v = CDbl(rawVal) Else v = 0

        Select Case True
            Case v > 0: fontColor = RGB(255, 0, 0)
            Case v < 0: fontColor = RGB(0, 176, 80)
            Case Else: fontColor = RGB(0, 0, 0)
        End Select

        Set shp = Nothing
        On Error Resume Next
        Set shp = pptSlide.Shapes(txtName)
        On Error GoTo 0

        If Not shp Is Nothing Then
            If shp.HasTextFrame Then
                With shp.TextFrame.TextRange
                    .Text = txtVal
                    .Font.Color.RGB = fontColor
                End With
            ElseIf shp.HasTextFrame2 Then
                With shp.TextFrame2.TextRange
                    .Text = txtVal
                    .Font.Fill.ForeColor.RGB = fontColor
                End With
            End If
        Else
            Debug.Print "未找到文本框: " & txtName
        End If
    Next i
End Sub

4️⃣ 使用方法

打开 Excel 和目标工作簿
打开 VBA 编辑器 (Alt + F11)
新建模块，将代码粘贴进去
修改 pptPath 为你的 PPT 路径
执行 两个涨跌幅表_及文本框一次完成()
检查 PPT 第 1 页和第 2 页表格及文本框内容

5️⃣ 注意事项

PPT 文本框名称必须与 Excel AF 列完全一致
涨跌幅列 AE 必须有数值或带 % 符号
Immediate 窗口会打印找不到的文本框名称，方便排查
建议保存 PPT 副本以免覆盖原文件