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

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

1 个答案: