Question

我已经附加了修改我的电子表格的整个工作脚本的代码，然后底部是我正在尝试编写正确的编码，以便将正确的单元格复制并粘贴为特殊粘贴（以保留图表）简报。

Option Explicit
Sub Autoformat()
Dim WSA As Worksheet
Dim rng1 As Range
Dim Rng2 As Range
Dim lpRange As Range
Dim Rng3 As Range       ' Used for finding last cell area
Dim sArr As Variant
Set WSA = ActiveSheet
Dim i As Long

sArr = Array("Suppressed", "Other Response Categories", "Requires Challenge Response", "Tracking Links Clicked", "Link Name (HTML)")
Rows("6:9").Delete ' Deletes Rows 6-9

With Application
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  .DisplayAlerts = False
  .EnableEvents = False
End With
For i = 0 To 3 Step 2
   Set lpRange = WSA.UsedRange
   Set rng1 = lpRange.Find(What:=sArr(i), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    MatchCase:=False)
   Set Rng2 = lpRange.Find(What:=sArr(i + 1), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    MatchCase:=False)
  On Error Resume Next
  If Not rng1 Is Nothing And Not Rng2 Is Nothing And Rng2.Row > rng1.Row Then
    WSA.Rows(rng1.Row & ":" & Rng2.Row - 1).Delete
  ElseIf Not rng1 Is Nothing And Rng2 Is Nothing Then
    WSA.Rows(rng1.Row).Delete
  End If
Next i
Set lpRange = WSA.UsedRange
Set Rng2 = lpRange.Find(What:=sArr(i), _
    LookAt:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    MatchCase:=False)

If Not Rng2 Is Nothing Then
 WSA.Rows(Rng2.Row & ":" & Rows.Count).Clear
End If

With Application
  .Calculation = xlCalculationAutomatic
  .ScreenUpdating = True
  .DisplayAlerts = True
  .EnableEvents = True
End With

'Ends Working Format Script
'Begin Attempts at autocopy as table and put into powerpoint

    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide

    ' Set range and find last cell
    Set Rng3 = WSA.Rows(1).Find("*", WSA.[A1], xlFormulas, , xlByColumns, xlPrevious)
    If Not Rng3 Is Nothing Then
        MsgBox "Rng3 contains " & Rng3.Address(0, 0)
    Else
        MsgBox WSA.Name & " row1 is completely empty", vbCritical
    End If

' Find last cell and copy entire spreadsheet
WSA.Range("A1:Rng3").CopyPicture

' Create instance of PowerPoint
Set PPApp = CreateObject("Powerpoint.Application")

' For automation to work, PowerPoint must be visible
PPApp.Visible = True

' Create a presentation
Set PPPres = PPApp.Presentations.Add

' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewSlide

' Add first slide to presentation
Set PPSlide = PPPres.Slides.Add(1, ppLayoutTitleOnly)

' Reference active slide
Set PPSlide = PPPres.Slides _
    (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

' Paste special the chart
PPSlide.Shapes.PasteSpecial

' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True


End Sub

现在，脚本打开powerpoint，创建一个新幻灯片，并将一个对象粘贴为图片，但它不会事先收集正确的单元格值。

我在哪里出错或者如何重写这个以实现我想要的目标？代码的整个顶部部分涉及格式化已导入的预先存在的Excel文档（到目前为止工作正常）但我试图使底部部分起作用。

Answer 1

Rng3是VBA变量，而不是Cell地址

WSA.Range("A1:Rng3").CopyPicture

您需要将两个单元格作为两个单独的参数传递这应该工作

WSA.Range("A1",Rng3).CopyPicture

虽然我已经通过将A1单元存储为VBA变量来完成它

Dim CellA1 As Range
Set CellA1 =WSA.Range("A1")

然后将两个范围作为参数传递

WSA.Range(CellA1,Rng3).CopyPicture

有关Worksheet.Range（Cell1）和Worksheet.Range（Cell1，Cell2）的更详细信息 http://msdn.microsoft.com/en-us/library/office/ff836512%28v=office.15%29.aspx

Excel宏用于查找包含数据的最后一个单元格，然后从该值复制整个页面并粘贴到powerpoint中

1 个答案: