我正在尝试使用 VBA 宏将信息从 excel 电子表格写入 Powerpoint

Question

我在 VBA 方面有点缺乏经验，所以我的问题可能非常基本。我有一个包含房间号列表的电子表格，我需要将它们复制到将作为显示器运行的 powerpoint 演示文稿中。

我的计划是在一张幻灯片上设置一个按钮来更新演示文稿。到目前为止，我已经为那个按钮编写了如下代码：

Sub CommandButton1_Click()
Dim xlapp As Excel.Application
Dim xldoc As Excel.Workbook
Dim Cell As Range
Dim rng As Range
Dim shapeslide
Dim shapename
Dim shapetext

Set xlapp = GetObject(, "Excel.Application")
Set xldoc = xlapp.ActiveWorkbook

Set rng = xldoc.Sheets(Sheet1).Range("a2:a" & Range("a" & xldoc.Sheets(Sheet1).Rows.Count).End(xlUp).Row)
For Each Cell In rng

shapeslide = Sheet1.Range("a" & Cell.Row)
shapename = Sheet1.Range("b" & Cell.Row)
shapetext = Sheet1.Range("c" & Cell.Row)

ActivePresentation.Slides(shapeslide).Shapes(shapename).TextEffect.Text = 
shapetext
Next Cell

ActivePresentation.Save
ActivePresentation.SlideShowSettings.Run

End Sub

但我在Set rng = xldoc.Sheets(Sheet1).Range("a2:a" & Range("a" & xldoc.Sheets(Sheet1).Rows.Count).End(xlUp).Row) 行中收到一个错误，上面写着“下标超出范围”。

作为参考，这里是相关的excel文档（这是我正在测试的一个更小更简单的版本）。

|---------------------|------------------|---------------------|
|      Index          |     Shape Name   |      Value          |
|---------------------|------------------|---------------------|
|          1          |     Subtitle 2   |      Room 133       |
|---------------------|------------------|---------------------|
|          2          |   Placeholder 2  |      Room 140       |
|---------------------|------------------|---------------------|
|          3          |   Placeholder 2  |      Room 220       |
|---------------------|------------------|---------------------|
|          4          |   Placeholder 2  |      Room 300       |
|---------------------|------------------|---------------------|

我知道这只是一个简单的错误，我知道“下标超出范围”消息是什么意思，但我不知道是什么原因造成的。

Answer 1

这个：

Set rng = xldoc.Sheets(Sheet1).Range("a2:a" & _
      Range("a" & xldoc.Sheets(Sheet1).Rows.Count).End(xlUp).Row)

应该是：

With xldoc.Sheets("Sheet1")
    Set rng = .Range("a2:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With

假设工作表的标签名称是“Sheet1”。

编辑：其余代码

Sub CommandButton1_Click()

    Dim xlapp As Excel.Application
    Dim xldoc As Excel.Workbook
    Dim Cell As Range
    Dim rng As Range
    Dim shapeslide
    Dim shapename
    Dim shapetext
    Dim sht As Excel.WorkSheet

    'see if Excel is open
    On Error Resume Next
    Set xlapp = GetObject(, "Excel.Application")
    On Error Goto 0

    If xlapp Is Nothing then
        Msgbox "Excel is not open!"
        Exit sub
    End If

    Set xldoc = xlapp.ActiveWorkbook
    Set sht = xldoc.Sheets("Sheet1")

    Set rng = sht.Range("a2:a" & sht.Range("a" & sht.Rows.Count).End(xlUp).Row)

    For Each Cell In rng.Cells

        shapeslide = sht.Range("a" & Cell.Row)
        shapename = sht.Range("b" & Cell.Row)
        shapetext = sht.Range("c" & Cell.Row)
        ActivePresentation.Slides(shapeslide).Shapes( _
                shapename).TextEffect.Text = shapetext
    Next Cell

    ActivePresentation.Save
    ActivePresentation.SlideShowSettings.Run

End Sub