Question

我正在尝试使用VBA将范围从Excel复制到Powerpoint。一旦我运行VBA宏。范围粘贴在字体大小= 6的powerpoint中。我希望粘贴到powerpoint时字体大小为9。

这是代码：

Sub ExcelRangeToPowerPoint()

Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape

'Columns("M:M").Select
'Columns("M:M").EntireColumn.AutoFit
'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("C8:M56")

'Create an Instance of PowerPoint
  On Error Resume Next

    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(Class:="PowerPoint.Application")

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")

    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.Paste

   'Special DataType:=ppPasteEnhancedMetafile


  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)


      myShapeRange.Left = 25
      'myShapeRange.Top = 27
      myShapeRange.Width = myPresentation.PageSetup.SlideWidth - 30
      myShapeRange.Height = myPresentation.PageSetup.SlideHeight - 120

    'Set position:
    'PowerPointApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
    'PowerPointApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue


'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Answer 1

不是复制Excel范围并粘贴到PowerPoint（将生成本机PowerPoint表），而是修改原始代码以包含以下内容。这将同时在PowerPoint中填充您的表并更改字体大小。

Dim tblShape As PowerPoint.Shape

    With mySlide.Shapes
        Set tblShape = .AddTable(NumRows:=rng.Rows.Count, NumColumns:=rng.Columns.Count, Left:=30, _
                                    Top:=110, Width:=660, Height:=320)
    End With
    Dim i As Long, j As Long, k As Long, l As Long
    k = 1 ' PowerPoint Table row
    For i = rng.Row To rng.Row + rng.Rows.Count - 1
        l = 1 'PowerPoint Table column
        For j = rng.Column To rng.Column + rng.Columns.Count - 1
            tblShape.Table.Cell(k, l).Shape.TextFrame.TextRange.Text = ThisWorkbook.ActiveSheet.Cells(i, j).Value
            tblShape.Table.Cell(k, l).Shape.TextFrame.TextRange.Font.Size = 15
            l = l + 1
        Next j
        k = k + 1
    Next i

Answer 2

如果您想保留源格式，只需使用粘贴特殊而不是粘贴，请将mySlide.Shapes.Paste更改为mySlide.Shapes.PasteSpecial ppPasteOLEObject

将excel范围复制到powerpoint时的字体大小

2 个答案: