excel - 将范围行数组转换为 Powerpoint 幻灯片表中的连续列

问题描述

我正在尝试复制 2 列范围的固定数量的行（例如每次 10 行的集合）并将这些行粘贴到包含 5 列 x 10 行（不包括标题）的重复模板幻灯片的表（例如表 3）中和顶行）。

编辑：

忘了补充说我正在将范围拾取到一个数组中，然后尝试粘贴它们。数组首先使用 2D QuickSort Array 程序在第一列就地（按 Ref）排序。

Option Explicit

Sub PasteRangesIntoSlideTables()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim oPPT As Object
Dim oPres As Object
Dim oSlide As Object
Dim Shp As Object
Dim Sht As Worksheet
Dim RowCnt&, i&, j&
Dim VarRng As Range
Dim Arr
Dim sNo$, sLabel$, NoOfSlides&, sDestPath$

sDestPath = ThisWorkbook.Path & "\Sample Template.pptx"

On Error Resume Next
Set oPPT = GetObject(sDestPath, "Powerpoint.Application")
'On Error GoTo 0

If Err.Number <> 0 Then
    Err.Clear
    On Error GoTo 0
    On Error GoTo ErrorHandler
End If

If oPPT Is Nothing Then
    Set oPPT = CreateObject("Powerpoint.Application")
End If

If oPPT.presentations.Count > 0 Then
    Set oPres = oPPT.presentations(Dir(sDestPath))
Else
    Set oPres = oPPT.presentations.Open(sDestPath)
End If

With oPPT
    .Visible = True
    For Each oSlide In oPres.slides
        Select Case LCase(Trim(oSlide.Shapes.Title.TextFrame.TextRange.Text))
            Case Is = LCase("Template Slide")
                oSlide.Name = "Slide0_TemplateSlide"
            Case Else

        End Select
    Next oSlide


    Set Sht = ThisWorkbook.Sheets("Sheet1")
    With Sht
        RowCnt = Application.Count(.Columns(1))

        For i = 1 To RowCnt
            Set VarRng = .Columns(1).Cells.Find(what:=i, LookIn:=xlValues, lookat:=xlWhole)
            sNo = VarRng.Value2                     ' grab Number
            sLabel = VarRng.Offset(0, 1).Value2 ' grab Label

            If Not VarRng Is Nothing Then
                Set VarRng = .Range(VarRng.Offset(1, 0), VarRng.End(xlDown).Offset(0, 1))
                Arr = VarRng.Value2
                QuickSortArray Arr, , , 1

                ' way to split this array to split into 10 rows each time to paste to columns 1 & 2 of slide table.
                ' then next <=10 to paste to columns 4 & 5 of slide table.
                ' If rows exceed 20, then duplicate the template slide `Slide0_TemplateSlide`.
                ' Repeat pasting procedure.
                ' If rows are <=10 then delete unwanted columns 3,4,5 of table to trim it.
                '..........................
                '..........................
                '..........................

                ' No of slides to be duplicated
                NoOfSlides = Int(UBound(Arr, 1) / 20) + IIf(((UBound(Arr, 1) Mod 20 < 20) And (UBound(Arr, 1) Mod 20 > 0)), 1, 0)
                For j = 1 to NoOfSlides
                    With oPres
                        Set oSlide = .slides("Slide0_TemplateSlide").Duplicate
                        With oSlide
                            '....................
                            '....................
                            '....................
                            '....................
                        End With
                    End With
                Next j
            End If
        Next i


    End With
End With

ExitSub:
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub

ErrorHandler:
MsgBox "Error Number: " & Err.Number & vbCrLf & "Source: " & Err.Source & vbCrLf & "Error Description: " & Err.Description
Err.Clear
On Error GoTo 0
Resume ExitSub

End Sub


Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    'Sort a 2-Dimensional array
    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3
    '
    'Posted by Jim Rech 10/20/98 Excel.Programming
    'Modifications, Nigel Heffernan:
    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs
    On Error Resume Next
    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Sub
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Sub
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Sub
    End If

    i = lngMin
    j = lngMax

    varMid = Empty
    varMid = CLng(Mid(SortArray((lngMin + lngMax) \ 2, lngColumn), 2, Trim(Len(SortArray((lngMin + lngMax) \ 2, lngColumn)))))

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) = vbError Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) > 17 Then
        i = lngMax
        j = lngMin
    End If

    While i <= j
        While CLng(Mid(SortArray(i, lngColumn), 2, Trim(Len(SortArray(i, lngColumn))))) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < CLng(Mid(SortArray(j, lngColumn), 2, Trim(Len(SortArray(j, lngColumn))))) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the rows
            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
            Next lngColTemp
            Erase arrRowTemp

            i = i + 1
            j = j - 1
        End If
    Wend

    If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub

仅在第 1 列和第 2 列中的工作表中有许多这样的 2 列不相交范围。

所以第一组 10 行将被粘贴到表的第 1 列和第 2 列中。该范围的剩余 <=10 行将被粘贴到接下来的 4 和 5 列中（第 3 列将只是一个分隔列）。因此，单个幻灯片表将仅包含 20 个范围行 (10 + 10)。

如果范围行超过 20，例如 31，则将 20 行粘贴到幻灯片表中（如 10 行在 1 和 2 列 + 10 行在 4 和 5 列），其余 11 行将粘贴到类似的重复幻灯片中表为 1 和 2 列中的 10 行和 4 和 5 列中的 1 行。因此每次范围行超过 20 行时，包含空白表格的模板幻灯片将被复制以填充。

我目前能够从工作表中获取 2 列范围。
我能够确定要从范围行数中创建多少张幻灯片。

例如 4 张幻灯片：

RowCnt = 63   'UBound(Arr, 1)
NoOfSlides = Int(UBound(Arr, 1) / 20) + IIf(((UBound(Arr, 1) Mod 20 < 20) And (UBound(Arr, 1) Mod 20 > 0)), 1, 0)

我无法确定如何在每张幻灯片中复制粘贴 20 行，即 1 列和 2 列中的 10 行以及幻灯片表的 4 列和 5 列中的 <=10 行。
如果范围行超过 20 行，我将无法复制幻灯片。
如果范围行仅填充表的 1 和 2 列，我无法删除表中不需要的列 3、4、5。

有没有人做过这样的事情？我附上了一个示例 xlsx 文件和示例 powerpoint 模板，以了解我想要做什么。

标签： excelvbapowerpointslide

excel - 将范围行数组转换为 Powerpoint 幻灯片表中的连续列

问题描述

解决方案

推荐阅读