我正在尝试使用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