Блог

Я пытаюсь загрузить данные из строк Excel в слайды PowerPoint, но код прерывается в последней строке и выдает ошибку

‘Значение выходит за пределы диапазона’.

Это первый раз, когда я работаю с VBA, поэтому я могу допустить действительно глупую ошибку, но я не могу исправить ее самостоятельно.

Я использую скрипт с этого сайта https://www.craig-tolley.co.uk/2011/06/08/vba-create-powerpoint-slide-for-each-row-in-excel-workbook/

Я попытался разбить строку кода, и кажется, что ошибка вызвана .Textrange.Текстовая часть, но она отлично используется во множестве других примеров?

Открытие Excel и загрузка значений WS.Cells(i, 1).Value работает, я попробовал это с Msgbox() помощью.

Таким образом, ошибка, похоже, связана с выбором и заполнением текстовых полей / фигур (только одного в этом примере). Я добавил пустые текстовые поля через меню разработчика в дополнение к обычным текстовым полям, которые уже были там, и я переименовал их на панели выбора.

Кто-нибудь может сказать мне, что я делаю не так?

 Sub ReferentieSlides()
    'Open the Excel workbook. Change the filename here.
    Dim OWB As New Excel.Workbook
    Set OWB = Excel.Application.Workbooks.Open("C:UsersMeFile.xlsm")

    'Grab the first Worksheet in the Workbook
    Dim WS As Excel.Worksheet
    Set WS = OWB.Worksheets(1)

    'Loop through each used row in Column A
    For i = 1 To WS.Range("A10").End(xlUp).Row
        'Copy the first slide and paste at the end of the presentation
        ActivePresentation.Slides(1).Copy
        ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count   1)
        'Change the text of the first text box on the slide.
        ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value  
    Next
End Sub
  

Код с исправлениями, которые были опробованы до сих пор:

 #If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Sub ReferentieSlides()


'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
'Set OWB = Excel.Application.Workbooks.Open("C:UsersIngeSchenkBoer amp; Croon Management BVManagement Solutions - BankMacro Referenties.xlsm")
Set OWB = Excel.Application.Workbooks.Open("C:UsersIngeSchenkDropboxTest2.xlsx")

'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)

'Define i
Dim i As Long

'Loop through each used row in Column A
For i = 1 To WS.Range("A" amp; Rows.Count).End(xlUp).Row
'Copy the first slide and paste at the end of the presentation
    ActivePresentation.Slides(1).Copy
    ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count   1)

    'Sleep for 10sec
    MsgBox "Execution is started"
    Sleep 10000 'delay in milliseconds
    MsgBox "Execution Resumed"

    'Change the text of the first text box on the slide.
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value

Next

End Sub

  

Из-за комментария Дэвида Земенса о том, что это макрос PPT, я изменил этот ответ. Проблема заключается в использовании функции End (xlup), которая не работает в PPT, у меня это сработало, но открытие Excel можно выполнить по-своему, если это работает для вас.

 Sub ReferentieSlides()
    'Open the Excel workbook. Change the filename here.
Dim OWB As Object
    Set OWB = CreateObject("T:usermeFile.xlsm")

    'Grab the first Worksheet in the Workbook
    Set WS = OWB.Sheets(1)


Set PPTObj = ActivePresentation  'Get the presentation that was opened

    'Loop through each used row in Column A
    'For i = 1 To WS.Range("A10").End(xlUp).Row
    For i = 1 To WS.Range("A1:A10").CurrentRegion.Rows.Count
        'Copy the first slide and paste at the end of the presentation
        PPTObj.Slides(1).Copy
        PPTObj.Slides.Paste (PPTObj.Slides.Count   1)
        'Change the text of the first text box on the slide.
        PPTObj.Slides(PPTObj.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value
    Next
End Sub