使用 for 循环将范围中的文本粘贴为 OLEObject

Question

我正在将来自 excel 的 table 作为 OLEObject 粘贴到 power point（见图 1）。我将 table 转换为范围，因为我合并了相同的日期值。到目前为止，我只能粘贴已排序的 table 和合并的单元格。

Sub TableData()
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld, sld1, sld2 As PowerPoint.slide
Dim r As Range
Dim lastRw As Long
Dim pptextbox As PowerPoint.Shape
Dim oLayout As CustomLayout
Application.DisplayAlerts = False     

lastRw = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

With ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
Set r = .Range
.Unlist ' convert the table back to a range
End With

ThisWorkbook.Worksheets("Sheet1").Range("B2:B" & lastRw).Select

MergeCells:

For Each r In Selection
    If r.Value = r.Offset(1, 0).Value And r.Value <> "" Then
        Range(r, r.Offset(1, 0)).Merge
        Range(r, r.Offset(1, 0)).HorizontalAlignment = xlCenter
        Range(r, r.Offset(1, 0)).VerticalAlignment = xlCenter
        GoTo MergeCells
    End If
Next
        Set ppt = CreateObject("PowerPoint.Application")
        Set sld1 = ppt.ActivePresentation.Slides.Add(ppt.ActivePresentation.Slides.Count + 1, ppLayoutBlank)

        set r=ThisWorkbook.Worksheets("Sheet1").Range("A:B" & lastRw)
        r.copy
        sld1.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
End Sub

现在除了table.

之外，我还想将每个特定日期对应的第一列的值分别粘贴为OLEObject（见图2）

我试图将其粘贴为 OLEObject，因为我想使用我在 excel 中使用的条件格式。据我了解，我需要运行一个 for 循环。但是，当我合并第二列时，我不知道如何处理。我将非常感谢您 suggestions/Solutions。看待，奥利弗

Answer 1

处理合并单元格总是有问题。因此，在合并单元格之前，应该使用动态数组一个一个地应用自动过滤器。然后可以对每个筛选结果应用 For 循环，将其单独粘贴到 PPT 幻灯片中。

Sub TableData()
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld, sld1, sld2 As PowerPoint.slide
Dim r As Range
Dim lastRw, lastRw1 As Long
Dim pptextbox As PowerPoint.Shape
Dim oLayout As CustomLayout
Application.DisplayAlerts = False

'Here column 'D' contains only unique dates   
lastRw = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row

Dim list() As Variant

ReDim list(2 To lastRw)

Dim i, j As Byte


For i = 2 To lastRw


        list(i) = Cells(i, 4).Value


Next i

lastRw1 = Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row
Set ppt = CreateObject("PowerPoint.Application")
Set sld1 = ppt.ActivePresentation.Slides.Add(ppt.ActivePresentation.Slides.Count + 1, 
 ppLayoutBlank)
For j = LBound(list) To UBound(list)


ActiveSheet.Range("A2:C" & lastRw1).AutoFilter Field:=2, Criteria1:= _
list(j)
lastRw1 = Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row

Set r = ThisWorkbook.Worksheets("Sheet1").Range("$A:A" & lastRw1)
        r.Copy

sld1.Shapes.PasteSpecial DataType:=ppPasteRTF, Link:=msoFalse

'Defining the position of the Text box          
If j < 10 Then

sld1.Shapes(j - 1).Top = 5
sld1.Shapes(j - 1).Left = 5 + (j - 1) * 100

Else

sld1.Shapes(j - 1).Top = 300
sld1.Shapes(j - 1).Left = 5 + (j - 9) * 100


End If
Next j
Sheet1.ShowAllData
End Sub

使用 for 循环将范围中的文本粘贴为 OLEObject

Pasting Text from Ranges as OLEObject using for loop

excel

powerpoint

vba