Как увеличить значение ячейки по горизонтали? в макросе VBA - PullRequest
Новая
       22

Как увеличить значение ячейки по горизонтали? в макросе VBA

0 голосов
/ 23 октября 2019

Я пишу программу VBA в powerpoint

Поток программы: Макрос VBA powerpoint должен открыть файл Excel и скопировать и заменить содержимое ячейки вконкретная форма в определенном слайде.
Здесь файл Excel имеет 21 столбец. Мне нужно скопировать и заменить ячейку данные на форму слайда на слайде № 8. Как увеличить значение ячейки по горизонтали? Как от a1 до b1 до 21 ячейки и повторить то же самое с начала

здесь код 

Sub xltoppt()

Dim xlApp As Object
Dim xlWorkBook As Object

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("C:\Users\\Desktop\test.xls", True, False)

Set xlApp = Nothing
Set xlWorkBook = Nothing

Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean
Dim shts As Worksheet
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Long
Dim j As Long

SheetName = ActiveSheet.Name

'Setting PasteRange to True means that Chart Option will not be used
PasteRange = True
RangeName = ("B1:B1") '"MyRange"
RangePasteType = "HTML"
RangeLink = True

PasteChart = False
PasteChartLink = True
ChartNumber = 1

AddSlidesToEnd = True

'Error testing
On Error Resume Next
Set TestSheet = Sheets(SheetName)
Set TestRange = Sheets(SheetName).Range(RangeName)
Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
On Error GoTo 0

'If TestSheet Is Nothing Then
'MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
Exit Sub
'End If

'If PasteRange And TestRange Is Nothing Then
MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
Exit Sub
'End If

'Look for existing instance
'On Error Resume Next
'Set ppApp = GetObject(, "PowerPoint.Application")
'On Error GoTo 0

'Create new instance if no instance exists
''If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
'Add a presentation if none exists
'If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add

'Make the instance visible
ppApp.Visible = True

'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes

If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                shp.TextFrame.TextRange.Text = replace(shp.TextFrame.TextRange.Text, "happy", Worksheets(SheetName).Range(RangeName))

End If

End If

Next shp
Next


End Sub```
...