将一系列单元格存储到数组中，稍后将其作为表格导出到powerpoint

Question

我有这两个for循环，它们试图为powerpoint演示创建幻灯片，但其中一个循环应该查找并存储引用数据透视表的特定单元格范围

这个尝试在一个工作表中查找 Excel 文件中表格的范围，并将它们实际存储在一个包含 40 个元素的数组中 (

redim RngGroup(1 to 40)

)

'Find table range
For Each foundCell In ActiveSheet.UsedRange.Cells
    
    If Not IsEmpty(foundCell) Then
        control = foundCell.Value
        
        If control = "Values" Then
            stRow = foundCell.Row
        End If
        
        If control = "Grand Total" Then
            endRow = foundCell.Row
        Else
            GoTo Line1
        End If
    Else
        GoTo Line1
    End If
    
    Set RngGroup(i) = Range(Cells(stRow, 1), Cells(endRow, 5))
    i = i + 1
    
Line1:
Next foundCell

这个尝试为表格和图表创建幻灯片

For Each Chrt In ActiveSheet.ChartObjects
            
    'Adding slide for table
    Set PPTSlide = PPTPres.Slides.Add(SIndex, ppLayoutCustom)
    
    Set TbRange = RngGroup(i)
    TbRange.Copy
    PPTSlide.Shapes.Paste
    i = i + 1
    'Copy chart
    Chrt.Copy
    
    'Create slide, set layout to custom
    Set PPTSlide = PPTPres.Slides.Add(SIndex + 1, ppLayoutCustom)
        PPTSlide.Shapes.Paste
    
    'Increment index value
    SIndex = SIndex + 2
Next Chrt

Answer 1

您没有回答我的澄清评论...因此，下一个代码假设两个搜索到的字符串存在于 A:A 或 D:D 列中，代码将设置活动 PowerPoint 演示文稿，插入新幻灯片（在最后一个存在的），创建一个形状并处理其表中的数组。在此之前，它会写入表头：

Sub PlaceRangesArrayInTable()
  Dim sh As Worksheet, lastR As Long, arr() As Range, arrAD, stRow As Long, iRow As Long
  Dim i As Long, j As Long, k As Long, r As Long, h As Long
  
  Set sh = ActiveSheet 'use here the necessary sheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
  
  arrAD = sh.Range("A1:D" & lastR).Value2 ' it assumes that in the first row there are headers
  
  ReDim arr(lastR / 2) 'maximum possible number of elements...
  For i = 2 To UBound(arrAD) 'place the necessary ranges in an array
    If arrAD(i, 1) = "Values" Or arrAD(i, 4) = "Values" Then stRow = i
        
     If arrAD(i, 1) = "Grand Total" Or arrAD(i, 4) = "Grand Total" Then
        Set arr(k) = sh.Range("A" & stRow, "E" & i)
        iRow = iRow + arr(k).rows.count: k = k + 1
     End If
  Next i
  
  ReDim Preserve arr(k - 1) 'keep only elements containing ranges

  'Now PowerPoint part:_________________________________________________________________
   'Dim ppt As PowerPoint.Application, ps As PowerPoint.Presentation, mySlide As PowerPoint.slide, myShape As PowerPoint.Shape
   Dim ppt As Object, ps As Object, mySlide As Object, myShape As Object
   
   Set ppt = GetObject(, "PowerPoint.application") 'get existing PowerPoint session
                                                   'you can create a new one if necessary
   Set ps = ppt.ActivePresentation 'set active presentation as the one to process on
   Set mySlide = ps.Slides.Add(ps.Slides.count + 1, 12) 'ppLayoutBlank (insert a blank slide as last)
   
   'add the necessary Table:
   Set myShape = mySlide.Shapes.AddTable(iRow + 1, 5) '+ 1 for the table header
   
   With myShape.table
       'create the header:
       For h = 1 To 5: .Cell(1, h).Shape.TextFrame.TextRange.text = "Col" & h: Next h
       For k = 0 To UBound(arr) 'Iterate between the array ranges:
            For i = 1 To arr(k).rows.count        'iterate between the range rows
                For j = 1 To arr(k).Columns.count 'iterate between the range columns
                    'copy  values in the table:
                    .Cell(i + r + 1, j).Shape.TextFrame.TextRange.text = _
                        arr(k).cells(i, j).text
                Next
            Next
            r = r + arr(k).rows.count
        Next k
    End With
   mySlide.Select 'activate the new inserted slide
   AppActivate ppt.ActiveWindow.Caption 'activate PowerPoint
   '___________________________________________________________________________________
End Sub

请在测试后发送一些反馈。